diff --git a/ouroboros-network-framework/CHANGELOG.md b/ouroboros-network-framework/CHANGELOG.md index 085f55db2b2..67eedcd6bb3 100644 --- a/ouroboros-network-framework/CHANGELOG.md +++ b/ouroboros-network-framework/CHANGELOG.md @@ -4,6 +4,17 @@ ### Breaking changes +* `Ouroboros.Network.Subscription` removed. +* `Ouroboros.Network.ErrorPolicy` removed. +* APIs removed from `Ouroboros.Network.Socket`: + * `NetworkMutableState` & friends, + * `withServerNode` and `withServerNode'`, + * `NetworkServerTracers`, + * `fromSnocket`, + * `beginConnection` +* `Ouroboros.Network.Server.Socket` replaced with a simpler server + implementation in `Test.Ouroboros.Network.Server` (in `ouroboros-network:testlib` component). + ### Non-breaking changes ## 0.15.0.0 -- 2025-01-02 diff --git a/ouroboros-network-framework/demo/connection-manager.hs b/ouroboros-network-framework/demo/connection-manager.hs index af64c266c90..69537e6d490 100644 --- a/ouroboros-network-framework/demo/connection-manager.hs +++ b/ouroboros-network-framework/demo/connection-manager.hs @@ -73,8 +73,8 @@ import Ouroboros.Network.Protocol.Handshake.Unversioned import Ouroboros.Network.Protocol.Handshake.Version (Acceptable (..), Queryable (..)) import Ouroboros.Network.RethrowPolicy +import Ouroboros.Network.Server qualified as Server import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) -import Ouroboros.Network.Server2 qualified as Server import Ouroboros.Network.Snocket (Snocket, socketSnocket) import Ouroboros.Network.Snocket qualified as Snocket import Ouroboros.Network.Util.ShowProxy diff --git a/ouroboros-network-framework/demo/ping-pong.hs b/ouroboros-network-framework/demo/ping-pong.hs index e782bafde0e..342099631b1 100644 --- a/ouroboros-network-framework/demo/ping-pong.hs +++ b/ouroboros-network-framework/demo/ping-pong.hs @@ -27,7 +27,6 @@ import Text.Printf (printf) import Network.Mux qualified as Mx -import Ouroboros.Network.ErrorPolicy import Ouroboros.Network.IOManager import Ouroboros.Network.Mux import Ouroboros.Network.Snocket @@ -35,9 +34,11 @@ import Ouroboros.Network.Snocket qualified as Snocket import Ouroboros.Network.Socket import Ouroboros.Network.Util.ShowProxy (ShowProxy (..)) +import Ouroboros.Network.Protocol.Handshake (HandshakeArguments (..)) import Ouroboros.Network.Protocol.Handshake.Codec import Ouroboros.Network.Protocol.Handshake.Unversioned import Ouroboros.Network.Protocol.Handshake.Version +import Test.Ouroboros.Network.Server qualified as Test.Server import Network.TypedProtocol.PingPong.Client as PingPong import Network.TypedProtocol.PingPong.Codec.CBOR as PingPong @@ -156,24 +157,21 @@ clientPingPong pipelined = serverPingPong :: IO Void serverPingPong = withIOManager $ \iomgr -> do - networkState <- newNetworkMutableState - _ <- async $ cleanNetworkMutableState networkState - withServerNode + Test.Server.with (Snocket.localSnocket iomgr) makeLocalBearer mempty - nullNetworkServerTracers - networkState - (AcceptedConnectionsLimit maxBound maxBound 0) defaultLocalSocketAddr - unversionedHandshakeCodec - noTimeLimitsHandshake - unversionedProtocolDataCodec - (HandshakeCallbacks acceptableVersion queryVersion) + HandshakeArguments { + haHandshakeTracer = nullTracer, + haHandshakeCodec = unversionedHandshakeCodec, + haVersionDataCodec = unversionedProtocolDataCodec, + haAcceptVersion = acceptableVersion, + haQueryVersion = queryVersion, + haTimeLimits = noTimeLimitsHandshake + } (unversionedProtocol (SomeResponderApplication app)) - nullErrorPolicies - $ \_ serverAsync -> - wait serverAsync -- block until async exception + $ \_ serverAsync -> wait serverAsync -- block until server finishes where app :: OuroborosApplicationWithMinimalCtx Mx.ResponderMode LocalAddress LBS.ByteString IO Void () @@ -251,24 +249,21 @@ clientPingPong2 = serverPingPong2 :: IO Void serverPingPong2 = withIOManager $ \iomgr -> do - networkState <- newNetworkMutableState - _ <- async $ cleanNetworkMutableState networkState - withServerNode + Test.Server.with (Snocket.localSnocket iomgr) makeLocalBearer mempty - nullNetworkServerTracers - networkState - (AcceptedConnectionsLimit maxBound maxBound 0) defaultLocalSocketAddr - unversionedHandshakeCodec - noTimeLimitsHandshake - unversionedProtocolDataCodec - (HandshakeCallbacks acceptableVersion queryVersion) + HandshakeArguments { + haHandshakeTracer = nullTracer, + haHandshakeCodec = unversionedHandshakeCodec, + haVersionDataCodec = unversionedProtocolDataCodec, + haAcceptVersion = acceptableVersion, + haQueryVersion = queryVersion, + haTimeLimits = noTimeLimitsHandshake + } (unversionedProtocol (SomeResponderApplication app)) - nullErrorPolicies - $ \_ serverAsync -> - wait serverAsync -- block until async exception + $ \_ serverAsync -> wait serverAsync -- block until async exception where app :: OuroborosApplicationWithMinimalCtx Mx.ResponderMode addr LBS.ByteString IO Void () diff --git a/ouroboros-network-framework/io-tests/Main.hs b/ouroboros-network-framework/io-tests/Main.hs index ec1f3f658ad..e1c1608436a 100644 --- a/ouroboros-network-framework/io-tests/Main.hs +++ b/ouroboros-network-framework/io-tests/Main.hs @@ -5,20 +5,18 @@ import Test.Tasty import Test.Ouroboros.Network.Driver qualified as Driver import Test.Ouroboros.Network.RawBearer qualified as RawBearer -import Test.Ouroboros.Network.Server2.IO qualified as Server2 +import Test.Ouroboros.Network.Server.IO qualified as Server import Test.Ouroboros.Network.Socket qualified as Socket -import Test.Ouroboros.Network.Subscription qualified as Subscription main :: IO () main = withUtf8 $ defaultMain tests tests :: TestTree tests = - testGroup "ouroboros-network-framework:io-tests" $ + testGroup "ouroboros-network-framework:io-tests" [ Driver.tests - , Server2.tests + , Server.tests , Socket.tests - , Subscription.tests , RawBearer.tests ] diff --git a/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Server2/IO.hs b/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Server/IO.hs similarity index 97% rename from ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Server2/IO.hs rename to ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Server/IO.hs index 83f1d6a8937..cbc1fe68674 100644 --- a/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Server2/IO.hs +++ b/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Server/IO.hs @@ -11,7 +11,7 @@ {-# OPTIONS_GHC -Wno-x-partial #-} #endif -module Test.Ouroboros.Network.Server2.IO (tests) where +module Test.Ouroboros.Network.Server.IO (tests) where import Control.Monad.Class.MonadThrow import System.Random (mkStdGen) @@ -34,7 +34,7 @@ import Test.Ouroboros.Network.Orphans () tests :: TestTree tests = testGroup "Ouroboros.Network" - [ testGroup "Server2" + [ testGroup "Server" [ testProperty "unidirectional IO" prop_unidirectional_IO , testProperty "bidirectional IO" prop_bidirectional_IO ] diff --git a/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Socket.hs b/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Socket.hs index 7b267b25204..22a09536aaf 100644 --- a/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Socket.hs @@ -49,7 +49,6 @@ import Network.TypedProtocol.ReqResp.Type qualified as ReqResp import Ouroboros.Network.Context import Ouroboros.Network.Driver -import Ouroboros.Network.ErrorPolicy import Ouroboros.Network.IOManager import Ouroboros.Network.Snocket import Ouroboros.Network.Socket @@ -61,11 +60,13 @@ import Network.Mux.Bearer qualified as Mx import Network.Mux.Timeout qualified as Mx import Network.Mux.Types qualified as Mx +import Ouroboros.Network.Protocol.Handshake import Ouroboros.Network.Protocol.Handshake.Codec import Ouroboros.Network.Protocol.Handshake.Unversioned import Ouroboros.Network.Protocol.Handshake.Version import Test.Ouroboros.Network.Orphans () +import Test.Ouroboros.Network.Server qualified as Test.Server import Test.QuickCheck import Test.Tasty (DependencyType (..), TestTree, after, testGroup) @@ -196,7 +197,6 @@ prop_socket_send_recv initiatorAddr responderAddr configureSock f xs = cv <- newEmptyTMVarIO sv <- newEmptyTMVarIO - networkState <- newNetworkMutableState {- The siblingVar is used by the initiator and responder to wait on each other before exiting. - Without this wait there is a risk that one side will finish first causing the Muxbearer to @@ -238,20 +238,21 @@ prop_socket_send_recv initiatorAddr responderAddr configureSock f xs = let snocket = socketSnocket iomgr res <- - withServerNode + Test.Server.with snocket Mx.makeSocketBearer ((. Just) <$> configureSock) - networkTracers - networkState - (AcceptedConnectionsLimit maxBound maxBound 0) responderAddr - unversionedHandshakeCodec - noTimeLimitsHandshake - unversionedProtocolDataCodec - (HandshakeCallbacks acceptableVersion queryVersion) + HandshakeArguments { + haHandshakeTracer = nullTracer, + haHandshakeCodec = unversionedHandshakeCodec, + haVersionDataCodec = unversionedProtocolDataCodec, + haAcceptVersion = acceptableVersion, + haQueryVersion = queryVersion, + haTimeLimits = noTimeLimitsHandshake + + } (unversionedProtocol (SomeResponderApplication responderApp)) - nullErrorPolicies $ \_ _ -> do void $ connectToNode snocket @@ -272,14 +273,6 @@ prop_socket_send_recv initiatorAddr responderAddr configureSock f xs = return (res == mapAccumL f 0 xs) where - networkTracers = NetworkServerTracers { - nstMuxTracer = activeMuxTracer, - nstHandshakeTracer = nullTracer, - nstErrorPolicyTracer = showTracing stdoutTracer, - nstAcceptPolicyTracer = nullTracer - } - - waitSibling :: StrictTVar IO Int -> IO () waitSibling cntVar = do atomically $ modifyTVar cntVar (\a -> a - 1) diff --git a/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Subscription.hs b/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Subscription.hs deleted file mode 100644 index 2411510da0a..00000000000 --- a/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Subscription.hs +++ /dev/null @@ -1,963 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-orphans #-} -#if __GLASGOW_HASKELL__ >= 908 -{-# OPTIONS_GHC -Wno-x-partial #-} -#endif - -module Test.Ouroboros.Network.Subscription (tests) where - -import Control.Concurrent hiding (threadDelay) -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad (replicateM, unless, when) -import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime.SI -import Control.Monad.Class.MonadTimer.SI -import Control.Monad.IOSim (runSimStrictShutdown) -import Control.Tracer -import Data.ByteString.Char8 qualified as BSC -import Data.ByteString.Lazy qualified as BL -import Data.Functor (void) -import Data.IP qualified as IP -import Data.List qualified as L -import Data.Map qualified as M -import Data.Void (Void) -import Data.Word -import Network.DNS qualified as DNS -import Network.Socket qualified as Socket -#if !defined(mingw32_HOST_OS) -import Network.Socket.ByteString.Lazy qualified as Socket (recv, sendAll) -#endif - -import Network.Mux qualified as Mx -import Network.Mux.Bearer qualified as Mx ---TODO: time utils should come from elsewhere -import Network.Mux.Time (microsecondsToDiffTime) - -import Network.TypedProtocol.ReqResp.Client qualified as ReqResp -import Network.TypedProtocol.ReqResp.Codec.CBOR qualified as ReqResp -import Network.TypedProtocol.ReqResp.Examples qualified as ReqResp -import Network.TypedProtocol.ReqResp.Server qualified as ReqResp - -import Ouroboros.Network.Protocol.Handshake.Codec -import Ouroboros.Network.Protocol.Handshake.Unversioned -import Ouroboros.Network.Protocol.Handshake.Version - -import Ouroboros.Network.Driver -import Ouroboros.Network.ErrorPolicy -import Ouroboros.Network.IOManager -import Ouroboros.Network.Mux -import Ouroboros.Network.Snocket -import Ouroboros.Network.Socket -import Ouroboros.Network.Subscription -import Ouroboros.Network.Subscription.Dns -import Ouroboros.Network.Subscription.Ip -import Ouroboros.Network.Subscription.PeerState -import Ouroboros.Network.Subscription.Subscriber -import Ouroboros.Network.Subscription.Worker (LocalAddresses (..), - WorkerParams (..)) - -import Test.Ouroboros.Network.Orphans () - -import Test.QuickCheck -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.QuickCheck (testProperty) -import Text.Printf -import Text.Show.Functions () - - -defaultMiniProtocolLimit :: Int -defaultMiniProtocolLimit = 3000000 - -testProtocols1 :: RunMiniProtocolWithMinimalCtx appType addr bytes m a b - -> OuroborosApplicationWithMinimalCtx appType addr bytes m a b -testProtocols1 chainSync = - OuroborosApplication [ - MiniProtocol { - miniProtocolNum = MiniProtocolNum 2, - miniProtocolLimits = MiniProtocolLimits { - maximumIngressQueue = defaultMiniProtocolLimit - }, - miniProtocolRun = chainSync - } - ] - --- | --- Allow to run a singly req-resp protocol. --- -testProtocols2 :: RunMiniProtocolWithMinimalCtx appType addr bytes m a b - -> OuroborosApplicationWithMinimalCtx appType addr bytes m a b -testProtocols2 reqResp = - OuroborosApplication [ - MiniProtocol { - miniProtocolNum = MiniProtocolNum 4, - miniProtocolLimits = MiniProtocolLimits { - maximumIngressQueue = defaultMiniProtocolLimit - }, - miniProtocolRun = reqResp - } - ] - - -activeTracer :: Tracer IO a -activeTracer = nullTracer --- activeTracer = _verboseTracer -- Dump log messages to stdout. - --- --- The list of all tests --- - -tests :: TestTree -tests = - testGroup "Subscription" - [ - testProperty "Resolve (Sim)" prop_resolv_sim - --, testProperty "Resolve (IO)" _prop_resolv_io - -- the above tests takes about 10 minutes to run due to delays in - -- realtime. - , testProperty "Resolve Subscribe (IO)" prop_sub_io - , testProperty "Send Receive with Dns worker (IO)" prop_send_recv - , testProperty "Send Receive with IP worker, Initiator and responder (IO)" - prop_send_recv_init_and_rsp - -- , testProperty "subscription demo" _demo - ] - -data LookupResult = LookupResult { - lrIpv4Result :: !(Either DNS.DNSError [Socket.SockAddr]) - , lrIpv4Delay :: !DiffTime - , lrIpv6Result :: !(Either DNS.DNSError [Socket.SockAddr]) - , lrIpv6Delay :: !DiffTime - , connectionRtt :: !DiffTime - } - -data LookupResultIO = LookupResultIO { - lrioIpv4Result :: !(Either DNS.DNSError [Word16]) - , lrioIpv6Result :: !(Either DNS.DNSError [Word16]) - , lrioFirst :: !Socket.Family - , lrioValency :: !Int - } - -mockResolver :: forall m. MonadDelay m => LookupResult -> Resolver m -mockResolver lr = Resolver lA lAAAA - where - lA :: DNS.Domain -> m (Either DNS.DNSError [Socket.SockAddr]) - lA _ = do - threadDelay (lrIpv4Delay lr) - return $ lrIpv4Result lr - - lAAAA :: DNS.Domain -> m (Either DNS.DNSError [Socket.SockAddr]) - lAAAA _ = do - threadDelay (lrIpv6Delay lr) - return $ lrIpv6Result lr - -withMockResolver :: MonadDelay m - => LookupResult - -> (Resolver m -> m a) - -> m a -withMockResolver lr k = k (mockResolver lr) - - -mockResolverIO :: StrictTMVar IO () - -> M.Map (Socket.Family, Word16) Socket.PortNumber - -> LookupResultIO - -> Resolver IO -mockResolverIO firstDoneMVar portMap lr = Resolver lA lAAAA - where - sidToPort sid = - case M.lookup sid portMap of - Just port -> port - Nothing -> error $ "missing port for sid " ++ show sid -- XXX - - lA :: DNS.Domain -> IO (Either DNS.DNSError [Socket.SockAddr]) - lA _ = do - when (lrioFirst lr == Socket.AF_INET6) $ do - void $ atomically $ takeTMVar firstDoneMVar - threadDelay 0.1 - let r = case lrioIpv4Result lr of - (Right sids) -> Right $ map (\sid -> Socket.SockAddrInet - (sidToPort (Socket.AF_INET, sid)) - (IP.toHostAddress "127.0.0.1")) sids - (Left e) -> Left e - when (lrioFirst lr == Socket.AF_INET) $ - atomically $ putTMVar firstDoneMVar () - return r - - lAAAA :: DNS.Domain -> IO (Either DNS.DNSError [Socket.SockAddr]) - lAAAA _ = do - when (lrioFirst lr == Socket.AF_INET) $ do - void $ atomically $ takeTMVar firstDoneMVar - threadDelay $ 0.1 + resolutionDelay - let r = case lrioIpv6Result lr of - (Right sids) -> Right $ map (\sid -> - Socket.SockAddrInet6 (sidToPort (Socket.AF_INET6, sid)) 0 - (IP.toHostAddress6 "::1") 0) sids - (Left e) -> Left e - when (lrioFirst lr == Socket.AF_INET6) $ - atomically $ putTMVar firstDoneMVar () - return r - -withMockResolverIO :: StrictTMVar IO () - -> M.Map (Socket.Family, Word16) Socket.PortNumber - -> LookupResultIO - -> (Resolver IO -> IO a) - -> IO a -withMockResolverIO firstDoneMVar portMap lr k = k (mockResolverIO firstDoneMVar portMap lr) - -instance Show LookupResult where - show a = printf "LookupResult: ipv4: %s delay %s ipv6: %s delay %s rtt %s" (show $ lrIpv4Result a) - (show $ lrIpv4Delay a) (show $ lrIpv6Result a) (show $ lrIpv6Delay a) - (show $ connectionRtt a) - -instance Show LookupResultIO where - show a = printf "LookupResultIO: ipv4: %s ipv6: %s first %s valency %d" - (show $ lrioIpv4Result a) - (show $ lrioIpv6Result a) - (show $ lrioFirst a) - (lrioValency a) - -instance Arbitrary DNS.DNSError where - arbitrary = oneof [ return DNS.SequenceNumberMismatch - , return DNS.RetryLimitExceeded - ] - -instance Arbitrary IP.IPv4 where - arbitrary = do - a <- replicateM 4 (choose (0,255)) - return $ IP.toIPv4 a - -instance Arbitrary IP.IPv6 where - arbitrary = do - a <- replicateM 8 (choose (0,0xffff)) - return $ IP.toIPv6 a - -instance Arbitrary Socket.Family where - arbitrary = oneof [ return Socket.AF_INET - , return Socket.AF_INET6 - ] - -instance Arbitrary LookupResult where - arbitrary = do - ipv4r <- arbitrary :: Gen (Either DNS.DNSError [IP.IPv4]) - ipv4d <- choose (0, 3000) - ipv6r <- arbitrary - ipv6d <- oneof [ choose (0, 3000) - , choose (ipv4d, ipv4d + round (1000 * resolutionDelay)) - ] - conrtt <- choose (0, 250) - - let minDistance = 10 -- 10ms minimum time between IPv4 and IPv6 result. - - {- - - For predictability we don't generate lookup results that are closer than 10ms to - - each other. Since 10ms is still less than resolutionDelay we can still test that - - behaviour related to resolutionDelay works correctly. - -} - let (ipv4d', ipv6d') = if abs (ipv4d - ipv6d) < minDistance - then if ipv4d > ipv6d then (ipv4d + minDistance, ipv6d) - else (ipv4d, ipv6d + minDistance) - else (ipv4d, ipv6d) - let sa4s = case ipv4r of - (Right ips) -> Right $ map (Socket.SockAddrInet 1 . IP.toHostAddress) ips - (Left e) -> Left e - let sa6s = case ipv6r of - (Right ips) -> Right $ map (\ip -> Socket.SockAddrInet6 1 0 - (IP.toHostAddress6 ip) 0) ips - (Left e) -> Left e - return $ LookupResult sa4s (microsecondsToDiffTime $ 1000 * ipv4d') sa6s - (microsecondsToDiffTime $ 1000 * ipv6d') - (microsecondsToDiffTime $ 1000 * conrtt) - - -instance Arbitrary LookupResultIO where - arbitrary = do - ipv4r <- oneof [ Left <$> arbitrary - , Right <$> shortList - ] - ipv6r <- oneof [ Left <$> arbitrary - , Right <$> shortList - ] - first <- arbitrary - valency <- choose (1, 8) - return $ LookupResultIO ipv4r ipv6r first valency - where - shortList :: Gen [Word16] - shortList = do - lx <- shuffle [0..3] - k <- choose (0, 4) - return $ take k lx - --- | Return true if `a` is a permutation of `b`. -permCheck :: (Ord o, Show o) => [o] -> [o] -> Property -permCheck a b = L.sort a === L.sort b - --- --- Properties --- - -prop_resolv :: forall m. - ( MonadAsync m - , MonadCatch m - , MonadDelay m - , MonadTimer m - ) - => LookupResult - -> m Property -prop_resolv lr = do - --say $ printf "%s" $ show lr - peerStatesVar <- newTVarIO () - x <- dnsResolve nullTracer (return lr) withMockResolver peerStatesVar (\_ _ s -> pure (AllowConnection s)) $ DnsSubscriptionTarget "shelley-1.iohk.example" 1 2 - !res <- checkResult <$> extractResult x [] - - {- - - We wait 100ms here so that the resolveAAAA and resolveA thread have time to - - exit, otherwise runSimStrictShutdown will complain about thread leaks. - - - - Change dnsResolv to return the two Asyncs so we can wait on them? - -} - threadDelay 0.1 - return $ tabulate "Resolution Result" [resolvLabel] res - - where - checkResult :: [Socket.SockAddr] -> Property - checkResult addrs = - case (lrIpv4Result lr, lrIpv6Result lr) of - (Left _, Left _) -> property $ null addrs - - (Right [], Right []) -> property $ null addrs - - (Right ea, Left _) -> - -- Expect a permutation of the result of the A lookup. - permCheck addrs ea - - (Left _, Right ea) -> - -- Expect a permutation of the result of the AAAA lookup. - permCheck addrs ea - - (Right sa4s, Right sa6s) -> - let (cntA, cntB, headFamily) = - if sa4s /= [] && (lrIpv4Delay lr + resolutionDelay < lrIpv6Delay lr - || null sa6s) - then (length sa4s, length sa6s, Socket.AF_INET) - else (length sa6s, length sa4s, Socket.AF_INET6) in - permCheck addrs (sa4s ++ sa6s) .&&. - sockAddrFamily (head addrs) === headFamily .&&. - alternateFamily addrs (sockAddrFamily (head addrs)) True - cntA cntB - - -- Once both the A and the AAAA lookup has returned the result should - -- alternate between the address families until one family is out of addresses. - -- This means that: - -- AAAABABABABABABBB is a valid sequense. - -- AAAABABAAABABABBB is not a valid sequense. - alternateFamily :: [Socket.SockAddr] -> Socket.Family -> Bool -> Int -> Int -> Bool - alternateFamily [] _ _ _ _ = True - alternateFamily _ _ _ (-1) _ = False - alternateFamily _ _ _ _ (-1) = False - alternateFamily (sa:sas) fa True cntA cntB = - if sockAddrFamily sa == fa - then alternateFamily sas fa True (cntA - 1) cntB - else alternateFamily sas (sockAddrFamily sa) False (cntB - 1) cntA - alternateFamily (sa:sas) fa False cntA cntB = - if sockAddrFamily sa == fa - then (cntB == 0) && alternateFamily sas fa False (cntA - 1) cntB - else alternateFamily sas (sockAddrFamily sa) False (cntB - 1) cntA - - extractResult :: SubscriptionTarget m Socket.SockAddr -> [Socket.SockAddr] -> m [Socket.SockAddr] - extractResult targets addrs = do - target_m <- getSubscriptionTarget targets - case target_m of - Just (addr, nextTargets) -> do - threadDelay (connectionRtt lr) - extractResult nextTargets (addr:addrs) - Nothing -> return $ reverse addrs - - resolvLabel :: String - resolvLabel = - case (lrIpv4Result lr, lrIpv6Result lr) of - (Left _, Left _) -> "A and AAAA error" - (Left _, Right []) -> "A error, AAAA no result" - (Left _, Right _) -> "A error, AAAA success" - (Right [], Left _) -> "A error, AAAA no result" - (Right _, Left _) -> "A success, AAAA error" - (Right _, Right _) | lrIpv6Delay lr < lrIpv4Delay lr -> "AAAA before A" - | lrIpv4Delay lr + resolutionDelay > lrIpv6Delay lr -> - "AAAA before A (Resolution Delay)" - | otherwise -> "A before AAAA" - -prop_resolv_sim :: LookupResult -> Property -prop_resolv_sim lr = - case runSimStrictShutdown $ prop_resolv lr of - Left _ -> property False - Right r -> r - -_prop_resolv_io :: LookupResult -> Property -_prop_resolv_io lr = ioProperty $ prop_resolv lr - -prop_sub_io :: LookupResultIO - -> Property -prop_sub_io lr = ioProperty $ withIOManager $ \iocp -> do - let serverIdsv4 = case lrioIpv4Result lr of - Left _ -> [] - Right r -> zip (repeat Socket.AF_INET) r - serverIdsv6 = case lrioIpv6Result lr of - Left _ -> [] - Right r -> zip (repeat Socket.AF_INET6) r - ipv4ClientCount = case lrioIpv4Result lr of - Left _ -> 0 - Right r -> length r - ipv6ClientCount = case lrioIpv6Result lr of - Left _ -> 0 - Right r -> length r - - clientCountVar <- newTVarIO (ipv4ClientCount + ipv6ClientCount) - serverCountVar <- newTVarIO (ipv4ClientCount + ipv6ClientCount) - serverPortMapVar <- newTVarIO M.empty - observerdConnectionOrderVar <- newTVarIO [] - firstDoneVar <- newEmptyTMVarIO - serverWaitVar <- newTVarIO False - - ipv4Servers <- replicateM (length serverIdsv4) (head <$> Socket.getAddrInfo Nothing (Just "127.0.0.1") - (Just "0")) - ipv6Servers <- replicateM (length serverIdsv6) (head <$> Socket.getAddrInfo Nothing (Just "::1") - (Just "0")) - - ipv4Client <- head <$> Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "0") - ipv6Client <- head <$> Socket.getAddrInfo Nothing (Just "::1") (Just "0") - - serverAids <- mapM (async . spawnServer serverCountVar serverPortMapVar - observerdConnectionOrderVar serverWaitVar) $ - zip (serverIdsv4 ++ serverIdsv6) $ ipv4Servers ++ ipv6Servers - - atomically $ do - c <- readTVar serverCountVar - when (c > 0) retry - - serverPortMap <- readTVarIO serverPortMapVar - networkState <- newNetworkMutableState - dnsSubscriptionWorker' - (socketSnocket iocp) - activeTracer - activeTracer - activeTracer - networkState - (return lr) - (withMockResolverIO firstDoneVar serverPortMap) - SubscriptionParams { - spLocalAddresses = - LocalAddresses - (Just $ Socket.addrAddress ipv4Client) - (Just $ Socket.addrAddress ipv6Client) - Nothing, - spConnectionAttemptDelay = const $ Just minConnectionAttemptDelay, - spErrorPolicies = nullErrorPolicies, - spSubscriptionTarget = DnsSubscriptionTarget "shelley-0.iohk.example" 6062 (lrioValency lr) - } - (\_ -> do - c <- readTVar clientCountVar - when (c > 0) retry - writeTVar serverWaitVar True) - (initiatorCallback clientCountVar) - - - mapM_ wait serverAids - - observerdConnectionOrder <- reverse <$> readTVarIO observerdConnectionOrderVar - - return $ property $ verifyOrder observerdConnectionOrder - - where - - verifyOrder - :: [(Socket.Family, Word16)] - -> Property - verifyOrder observerdConnectionOrder = - case (lrioIpv4Result lr, lrioIpv6Result lr) of - (Left _, Left _) -> counterexample "null" $ null observerdConnectionOrder - (Right [], Right []) -> counterexample "null" $ null observerdConnectionOrder - (Left _, Right a) -> a === map snd observerdConnectionOrder - (Right a, Left _) -> a === map snd observerdConnectionOrder - (Right a, Right []) -> a === map snd observerdConnectionOrder - (Right [], Right a) -> a === map snd observerdConnectionOrder - (Right r4, Right r6) -> - not (null observerdConnectionOrder) .&&. - (lrioFirst lr === fst (head observerdConnectionOrder)) .&&. - permCheck (r4 ++ r6) (map snd observerdConnectionOrder) - - initiatorCallback - :: StrictTVar IO Int - -> Socket.Socket - -> IO () - initiatorCallback clientCountVar _sd = do -#if !defined(mingw32_HOST_OS) - Socket.sendAll _sd $ BL.singleton 42 - _ <- Socket.recv _sd 1 -#endif - - atomically $ modifyTVar clientCountVar (\a -> a - 1) - - spawnServer serverCountVar serverPortMapVar traceVar stopVar (sid, addr) = - bracket - (Socket.socket (Socket.addrFamily addr) Socket.Stream Socket.defaultProtocol) - Socket.close - (\sd -> do - Socket.setSocketOption sd Socket.ReuseAddr 1 - Socket.bind sd (Socket.addrAddress addr) - localPort <- Socket.socketPort sd - atomically $ modifyTVar serverPortMapVar (M.insert sid localPort) - Socket.listen sd 10 - atomically $ modifyTVar serverCountVar (\a -> a - 1) - bracket - (Socket.accept sd) - (\(sd',_) -> Socket.close sd') - (\(_sd',_) -> do -#if !defined(mingw32_HOST_OS) - buf <- Socket.recv _sd' 1 - Socket.sendAll _sd' buf -#endif - - atomically $ modifyTVar traceVar (\sids -> sid:sids) - atomically $ do - doneWaiting <- readTVar stopVar - unless doneWaiting retry - ) - ) - - -prop_send_recv - :: (Int -> Int -> (Int, Int)) - -> [Int] - -> Socket.Family - -> Property -prop_send_recv f xs _first = ioProperty $ withIOManager $ \iocp -> do - - let lr = LookupResultIO (Right [0]) (Right [0]) Socket.AF_INET6 1 - hints = Just $ Socket.defaultHints {Socket.addrSocketType = Socket.Stream} - - responderAddress0:_ <- Socket.getAddrInfo hints (Just "127.0.0.1") Nothing - - initiatorAddr4:_ <- Socket.getAddrInfo hints (Just "127.0.0.1") (Just "0") - initiatorAddr6:_ <- Socket.getAddrInfo hints (Just "::1") (Just "0") - - -- listening socket - bracket (Socket.openSocket responderAddress0) Socket.close $ \socket -> do - Socket.bind socket (Socket.addrAddress responderAddress0) - Socket.listen socket 10 - - responderAddr <- Socket.getSocketName socket - let responderPort = case responderAddr of - Socket.SockAddrInet port _ -> port - _ -> error "impossible happened" - serverPortMap = M.fromList [((Socket.AF_INET, 0), responderPort), ((Socket.AF_INET6, 0), responderPort)] - faultyAddress:_ <- Socket.getAddrInfo Nothing (Just "::1") (Just $ show responderPort) - - firstDoneVar <- newEmptyTMVarIO - - cv <- newEmptyTMVarIO - sv <- newEmptyTMVarIO - siblingVar <- newTVarIO 2 - tbl <- newConnectionTable - clientTbl <- newConnectionTable - - let -- Server Node; only req-resp server - responderApp :: OuroborosApplicationWithMinimalCtx - Mx.ResponderMode Socket.SockAddr BL.ByteString IO Void () - responderApp = testProtocols2 reqRespResponder - - reqRespResponder = - ResponderProtocolOnly $ - MiniProtocolCb $ \_ctx channel -> do - (r, trailing) <- runPeer (tagTrace "Responder" activeTracer) - ReqResp.codecReqResp - channel - (ReqResp.reqRespServerPeer (ReqResp.reqRespServerMapAccumL (\a -> pure . f a) 0)) - atomically $ putTMVar sv r - ((), trailing) - <$ waitSiblingSub siblingVar - - -- Client Node; only req-resp client - initiatorApp :: OuroborosApplicationWithMinimalCtx - Mx.InitiatorMode Socket.SockAddr BL.ByteString IO () Void - initiatorApp = testProtocols2 reqRespInitiator - - reqRespInitiator = - InitiatorProtocolOnly $ - MiniProtocolCb $ \_ctx channel -> do - (r, trailing) <- runPeer (tagTrace "Initiator" activeTracer) - ReqResp.codecReqResp - channel - (ReqResp.reqRespClientPeer (ReqResp.reqRespClientMap xs)) - atomically $ putTMVar cv r - ((), trailing) <$ - waitSiblingSub siblingVar - - peerStatesVar <- newPeerStatesVar - let sn = socketSnocket iocp - withDummyServer faultyAddress $ - withServerNode' - sn - Mx.makeSocketBearer - nullNetworkServerTracers - (NetworkMutableState tbl peerStatesVar) - (AcceptedConnectionsLimit maxBound maxBound 0) - socket - unversionedHandshakeCodec - noTimeLimitsHandshake - unversionedProtocolDataCodec - (HandshakeCallbacks acceptableVersion queryVersion) - (unversionedProtocol (SomeResponderApplication responderApp)) - nullErrorPolicies - $ \_ _ -> do - dnsSubscriptionWorker' - sn activeTracer activeTracer activeTracer - (NetworkMutableState clientTbl peerStatesVar) - (return lr) - (withMockResolverIO firstDoneVar serverPortMap) - SubscriptionParams { - spLocalAddresses = - LocalAddresses - (Just $ Socket.addrAddress initiatorAddr4) - (Just $ Socket.addrAddress initiatorAddr6) - Nothing, - spConnectionAttemptDelay = \_ -> Just minConnectionAttemptDelay, - spErrorPolicies = nullErrorPolicies, - spSubscriptionTarget = DnsSubscriptionTarget "shelley-0.iohk.example" responderPort 1 - } - (\_ -> waitSiblingSTM siblingVar) - (connectToNodeSocket - iocp - ConnectToArgs { - ctaHandshakeCodec = unversionedHandshakeCodec, - ctaHandshakeTimeLimits = noTimeLimitsHandshake, - ctaVersionDataCodec = unversionedProtocolDataCodec, - ctaConnectTracers = nullNetworkConnectTracers, - ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion - } - (unversionedProtocol initiatorApp)) - - res <- atomically $ (,) <$> takeTMVar sv <*> takeTMVar cv - return (res == L.mapAccumL f 0 xs) - - where - withDummyServer :: Socket.AddrInfo - -> IO a - -> IO a - withDummyServer addr k = - bracket - (Socket.socket (Socket.addrFamily addr) Socket.Stream Socket.defaultProtocol) - Socket.close - (\sd -> do - -- bind the socket, so that it is used, but don't listen to it. - Socket.setSocketOption sd Socket.ReuseAddr 1 - Socket.bind sd (Socket.addrAddress addr) - k - ) - - -data ReqRspCfg = ReqRspCfg { - rrcTag :: !String - , rrcServerVar :: !(StrictTMVar IO Int) - , rrcClientVar :: !(StrictTMVar IO [Int]) - , rrcSiblingVar :: !(StrictTVar IO Int) -} - -newReqRspCfg :: String -> StrictTVar IO Int -> IO ReqRspCfg -newReqRspCfg tag siblingVar = do - sv <- newEmptyTMVarIO - cv <- newEmptyTMVarIO - return $ ReqRspCfg tag sv cv siblingVar - -prop_send_recv_init_and_rsp - :: (Int -> Int -> (Int, Int)) - -> [Int] - -> Property -prop_send_recv_init_and_rsp f xs = ioProperty $ withIOManager $ \iocp -> do - - responderAddr4A:_ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "0") - responderAddr4B:_ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "0") - - addrAVar <- newEmptyTMVarIO - addrBVar <- newEmptyTMVarIO - - siblingVar <- newTVarIO 4 - {- 4 comes from one initiator and responder running on the server and one initiator and - - and responder running on the client. - -} - - tblA <- newConnectionTable - tblB <- newConnectionTable - - rrcfgA <- newReqRspCfg "A" siblingVar - rrcfgB <- newReqRspCfg "B" siblingVar - - stVar <- newPeerStatesVar - - a_aid <- async $ startPassiveServer - iocp - tblA - stVar - (Socket.addrAddress responderAddr4A) - addrAVar - rrcfgA - - b_aid <- async $ startActiveServer - iocp - tblB - stVar - (Socket.addrAddress responderAddr4B) - addrBVar - addrAVar - rrcfgB - - (resA, resB) <- waitBoth a_aid b_aid - return $ (resA == L.mapAccumL f 0 xs) && (resB == L.mapAccumL f 0 xs) - - where - - appX :: ReqRspCfg - -> OuroborosApplicationWithMinimalCtx - Mx.InitiatorResponderMode Socket.SockAddr BL.ByteString IO () () - appX cfg = testProtocols2 (reqResp cfg) - - reqResp ReqRspCfg {rrcTag, rrcServerVar, rrcClientVar, rrcSiblingVar} = - InitiatorAndResponderProtocol - -- Initiator - (MiniProtocolCb $ \_ctx channel -> do - (r, trailing) <- runPeer (tagTrace (rrcTag ++ " Initiator") activeTracer) - ReqResp.codecReqResp - channel - (ReqResp.reqRespClientPeer (ReqResp.reqRespClientMap xs)) - atomically $ putTMVar rrcClientVar r - -- wait for our responder and peer - ((), trailing) - <$ waitSiblingSub rrcSiblingVar - ) - -- Responder - (MiniProtocolCb $ \_ctx channel -> do - (r, trailing) <- runPeer (tagTrace (rrcTag ++ " Responder") activeTracer) - ReqResp.codecReqResp - channel - (ReqResp.reqRespServerPeer (ReqResp.reqRespServerMapAccumL - (\a -> pure . f a) 0)) - atomically $ putTMVar rrcServerVar r - -- wait for our initiator and peer - ((), trailing) - <$ waitSiblingSub rrcSiblingVar - ) - - startPassiveServer iocp tbl stVar responderAddr localAddrVar rrcfg = withServerNode - (socketSnocket iocp) - Mx.makeSocketBearer - ((. Just) <$> configureSocket) - nullNetworkServerTracers - (NetworkMutableState tbl stVar) - (AcceptedConnectionsLimit maxBound maxBound 0) - responderAddr - unversionedHandshakeCodec - noTimeLimitsHandshake - unversionedProtocolDataCodec - (HandshakeCallbacks acceptableVersion queryVersion) - (unversionedProtocol (SomeResponderApplication (appX rrcfg))) - nullErrorPolicies - $ \localAddr _ -> do - atomically $ putTMVar localAddrVar localAddr - r <- atomically $ (,) <$> takeTMVar (rrcServerVar rrcfg) - <*> takeTMVar (rrcClientVar rrcfg) - waitSibling (rrcSiblingVar rrcfg) - return r - - startActiveServer iocp tbl stVar responderAddr localAddrVar remoteAddrVar rrcfg = - let sn = socketSnocket iocp - in withServerNode - sn - Mx.makeSocketBearer - ((. Just) <$> configureSocket) - nullNetworkServerTracers - (NetworkMutableState tbl stVar) - (AcceptedConnectionsLimit maxBound maxBound 0) - responderAddr - unversionedHandshakeCodec - noTimeLimitsHandshake - unversionedProtocolDataCodec - (HandshakeCallbacks acceptableVersion queryVersion) - (unversionedProtocol (SomeResponderApplication (appX rrcfg))) - nullErrorPolicies - $ \localAddr _ -> do - peerStatesVar <- newPeerStatesVar - atomically $ putTMVar localAddrVar localAddr - remoteAddr <- atomically $ takeTMVar remoteAddrVar - _ <- subscriptionWorker - sn - activeTracer - activeTracer - (NetworkMutableState tbl peerStatesVar) - WorkerParams { - wpLocalAddresses = LocalAddresses (Just localAddr) Nothing Nothing, - wpSelectAddress = selectSockAddr, - wpConnectionAttemptDelay = \_ -> Just minConnectionAttemptDelay, - wpSubscriptionTarget = pure $ listSubscriptionTarget [remoteAddr], - wpValency = 1 - } - nullErrorPolicies - (\_ -> waitSiblingSTM (rrcSiblingVar rrcfg)) - (connectToNodeSocket - iocp - ConnectToArgs { - ctaHandshakeCodec = unversionedHandshakeCodec, - ctaHandshakeTimeLimits = noTimeLimitsHandshake, - ctaVersionDataCodec = unversionedProtocolDataCodec, - ctaConnectTracers = nullNetworkConnectTracers, - ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion - } - (unversionedProtocol (appX rrcfg))) - - atomically $ (,) <$> takeTMVar (rrcServerVar rrcfg) - <*> takeTMVar (rrcClientVar rrcfg) - -waitSiblingSub :: StrictTVar IO Int -> IO () -waitSiblingSub cntVar = do - atomically $ modifyTVar cntVar (\a -> a - 1) - waitSibling cntVar - -waitSiblingSTM :: StrictTVar IO Int -> STM IO () -waitSiblingSTM cntVar = do - cnt <- readTVar cntVar - unless (cnt == 0) retry - -waitSibling :: StrictTVar IO Int -> IO () -waitSibling = atomically . waitSiblingSTM - -{- - - XXX Doesn't really test anything, doesn't exit in a resonable time. - - XXX Depends on external network config - - unbound DNS config example: -local-data: "shelley-1.iohk.example. IN A 192.168.1.115" -local-data: "shelley-1.iohk.example. IN A 192.168.1.215" -local-data: "shelley-1.iohk.example. IN A 192.168.1.216" -local-data: "shelley-1.iohk.example. IN A 192.168.1.100" -local-data: "shelley-1.iohk.example. IN A 192.168.1.101" -local-data: "shelley-1.iohk.example. IN A 127.0.0.1" -local-data: "shelley-1.iohk.example. IN AAAA ::1" - -local-data: "shelley-0.iohk.example. IN AAAA ::1" --} -_demo :: Property -_demo = ioProperty $ withIOManager $ \iocp -> do - server:_ <- Socket.getAddrInfo Nothing (Just "192.168.1.100") (Just "6062") - server':_ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "6062") - server6:_ <- Socket.getAddrInfo Nothing (Just "::1") (Just "6062") - server6':_ <- Socket.getAddrInfo Nothing (Just "::1") (Just "6064") - client:_ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "0") - client6:_ <- Socket.getAddrInfo Nothing (Just "::1") (Just "0") - - tbl <- newConnectionTable - clientTbl <- newConnectionTable - peerStatesVar <- newPeerStatesVar - stVar <- newPeerStatesVar - - spawnServer iocp tbl stVar server 10000 - spawnServer iocp tbl stVar server' 10000 - spawnServer iocp tbl stVar server6 100 - spawnServer iocp tbl stVar server6' 45 - - _ <- dnsSubscriptionWorker - (socketSnocket iocp) - activeTracer activeTracer activeTracer - (NetworkMutableState clientTbl peerStatesVar) - SubscriptionParams { - spLocalAddresses = - LocalAddresses - (Just $ Socket.addrAddress client) - (Just $ Socket.addrAddress client6) - Nothing, - spConnectionAttemptDelay = \_ -> Just minConnectionAttemptDelay, - spSubscriptionTarget = DnsSubscriptionTarget "shelley-0.iohk.example" 6064 1, - spErrorPolicies = nullErrorPolicies - - } - (connectToNodeSocket - iocp - ConnectToArgs { - ctaHandshakeCodec = unversionedHandshakeCodec, - ctaHandshakeTimeLimits = noTimeLimitsHandshake, - ctaVersionDataCodec = unversionedProtocolDataCodec, - ctaConnectTracers = nullNetworkConnectTracers, - ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion - } - (unversionedProtocol appReq)) - - threadDelay 130 - -- bring the servers back again - spawnServer iocp tbl stVar server6 10000 - spawnServer iocp tbl stVar server6' 10000 - threadDelay 1000 - return () - - where - - spawnServer iocp tbl stVar addr delay = - void $ async $ withServerNode - (socketSnocket iocp) - Mx.makeSocketBearer - ((. Just) <$> configureSocket) - nullNetworkServerTracers - (NetworkMutableState tbl stVar) - (AcceptedConnectionsLimit maxBound maxBound 0) - (Socket.addrAddress addr) - unversionedHandshakeCodec - noTimeLimitsHandshake - unversionedProtocolDataCodec - (HandshakeCallbacks acceptableVersion queryVersion) - (unversionedProtocol (SomeResponderApplication appRsp)) - nullErrorPolicies - (\_ _ -> threadDelay delay) - - - appReq = - testProtocols1 $ - InitiatorProtocolOnly $ - MiniProtocolCb $ \_ _ -> error "req fail" - - appRsp = - testProtocols1 $ - ResponderProtocolOnly $ - MiniProtocolCb $ \_ _ -> error "rsp fail" - -data WithThreadAndTime a = WithThreadAndTime { - wtatOccuredAt :: !UTCTime - , wtatWithinThread :: !ThreadId - , wtatEvent :: !a - } - -instance (Show a) => Show (WithThreadAndTime a) where - show WithThreadAndTime {wtatOccuredAt, wtatWithinThread, wtatEvent} = - printf "%s: %s: %s" (show wtatOccuredAt) (show wtatWithinThread) (show wtatEvent) - -_verboseTracer :: Show a => Tracer IO a -_verboseTracer = threadAndTimeTracer $ Tracer (BSC.putStrLn . BSC.pack . show) - -threadAndTimeTracer :: Tracer IO (WithThreadAndTime a) -> Tracer IO a -threadAndTimeTracer tr = Tracer $ \s -> do - !now <- getCurrentTime - !tid <- myThreadId - traceWith tr $ WithThreadAndTime now tid s - -data WithTag a = WithTag { - wtTag :: !String - , wtEvent :: !a - } - -instance (Show a) => Show (WithTag a) where - show WithTag {wtTag, wtEvent} = - printf "%s: %s" wtTag (show wtEvent) - -tagTrace :: String -> Tracer IO (WithTag a) -> Tracer IO a -tagTrace tag tr = Tracer $ \s -> traceWith tr $ WithTag tag s diff --git a/ouroboros-network-framework/ouroboros-network-framework.cabal b/ouroboros-network-framework/ouroboros-network-framework.cabal index 44b0158fb3a..d18cc58524b 100644 --- a/ouroboros-network-framework/ouroboros-network-framework.cabal +++ b/ouroboros-network-framework/ouroboros-network-framework.cabal @@ -39,7 +39,6 @@ library Ouroboros.Network.Driver.Limits Ouroboros.Network.Driver.Simple Ouroboros.Network.Driver.Stateful - Ouroboros.Network.ErrorPolicy Ouroboros.Network.IOManager Ouroboros.Network.InboundGovernor Ouroboros.Network.InboundGovernor.Event @@ -55,39 +54,26 @@ library Ouroboros.Network.Protocol.Handshake.Version Ouroboros.Network.RawBearer Ouroboros.Network.RethrowPolicy + Ouroboros.Network.Server Ouroboros.Network.Server.ConnectionTable Ouroboros.Network.Server.RateLimiting - Ouroboros.Network.Server.Socket - Ouroboros.Network.Server2 Ouroboros.Network.Snocket Ouroboros.Network.Socket - Ouroboros.Network.Subscription - Ouroboros.Network.Subscription.Client - Ouroboros.Network.Subscription.Dns - Ouroboros.Network.Subscription.Ip - Ouroboros.Network.Subscription.PeerState - Ouroboros.Network.Subscription.Subscriber - Ouroboros.Network.Subscription.Worker Simulation.Network.Snocket -- other-extensions: build-depends: -- ^ only to derive nothunk instances Win32-network ^>=0.2, - async >=2.1 && <2.3, base >=4.12 && <4.21, bytestring >=0.10 && <0.13, - cardano-prelude, cborg >=0.2.1 && <0.3, containers >=0.5 && <0.8, contra-tracer, deepseq, - dns <4.3, hashable, io-classes ^>=1.5.0, - iproute >=1.7 && <1.8, monoidal-synchronisation ^>=0.1.0.6, - mtl, network ^>=3.1.4, network-mux ^>=0.6, nothunks, @@ -98,7 +84,6 @@ library quiet, random, si-timers, - stm, strict-stm, text, typed-protocols ^>=0.3, @@ -131,6 +116,7 @@ library testlib Test.Ouroboros.Network.InboundGovernor.Utils Test.Ouroboros.Network.Orphans Test.Ouroboros.Network.RawBearer.Utils + Test.Ouroboros.Network.Server other-modules: build-depends: @@ -175,9 +161,8 @@ test-suite sim-tests Test.Ouroboros.Network.ConnectionManager Test.Ouroboros.Network.RateLimiting Test.Ouroboros.Network.RawBearer - Test.Ouroboros.Network.Server2.Sim + Test.Ouroboros.Network.Server.Sim Test.Ouroboros.Network.Socket - Test.Ouroboros.Network.Subscription Test.Simulation.Network.Snocket build-depends: @@ -188,10 +173,8 @@ test-suite sim-tests containers, contra-tracer, directory, - dns, io-classes, io-sim, - iproute, monoidal-synchronisation, network, network-mux, @@ -247,21 +230,17 @@ test-suite io-tests other-modules: Test.Ouroboros.Network.Driver Test.Ouroboros.Network.RawBearer - Test.Ouroboros.Network.Server2.IO + Test.Ouroboros.Network.Server.IO Test.Ouroboros.Network.Socket - Test.Ouroboros.Network.Subscription build-depends: QuickCheck, base >=4.14 && <4.21, bytestring, - containers, contra-tracer, directory, - dns, io-classes, io-sim, - iproute, monoidal-synchronisation, network, network-mux, @@ -308,6 +287,7 @@ executable demo-ping-pong network-mux, ouroboros-network-api, ouroboros-network-framework, + ouroboros-network-framework:testlib, typed-protocols-examples, default-language: Haskell2010 diff --git a/ouroboros-network-framework/sim-tests/Main.hs b/ouroboros-network-framework/sim-tests/Main.hs index 29a51dbf4ed..ab9d05de52b 100644 --- a/ouroboros-network-framework/sim-tests/Main.hs +++ b/ouroboros-network-framework/sim-tests/Main.hs @@ -5,7 +5,7 @@ import Test.Tasty import Test.Ouroboros.Network.ConnectionManager qualified as ConnectionManager import Test.Ouroboros.Network.RateLimiting qualified as RateLimiting -import Test.Ouroboros.Network.Server2.Sim qualified as Server2 +import Test.Ouroboros.Network.Server.Sim qualified as Server import Test.Simulation.Network.Snocket qualified as Snocket main :: IO () @@ -15,7 +15,7 @@ tests :: TestTree tests = testGroup "ouroboros-network-framework:sim-tests" [ ConnectionManager.tests - , Server2.tests + , Server.tests , RateLimiting.tests , Snocket.tests ] diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/ConnectionManager.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/ConnectionManager.hs index 9ffc52a5eee..83d36cba17c 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/ConnectionManager.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/ConnectionManager.hs @@ -80,7 +80,7 @@ tests :: TestTree tests = testGroup "Ouroboros.Network.ConnectionManager" [ -- generators, shrinkers properties - -- TODO: replace these tests with 'Test.Ouroboros.Network.Server2' simulation. + -- TODO: replace these tests with 'Test.Ouroboros.Network.Server' simulation. testProperty "overwritten" unit_overwritten , testProperty "timeoutExpired" unit_timeoutExpired ] diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server2/Sim.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs similarity index 99% rename from ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server2/Sim.hs rename to ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs index a0e2a206d04..80369565196 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server2/Sim.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs @@ -19,7 +19,7 @@ -- for 'debugTracer' {-# OPTIONS_GHC -Wno-redundant-constraints #-} -module Test.Ouroboros.Network.Server2.Sim (tests) where +module Test.Ouroboros.Network.Server.Sim (tests) where import Control.Applicative (Alternative ((<|>))) import Control.Concurrent.Class.MonadSTM qualified as LazySTM @@ -86,9 +86,9 @@ import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) import Ouroboros.Network.Protocol.Handshake.Codec (noTimeLimitsHandshake, timeLimitsHandshake) import Ouroboros.Network.Protocol.Handshake.Unversioned +import Ouroboros.Network.Server (RemoteTransitionTrace) +import Ouroboros.Network.Server qualified as Server import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) -import Ouroboros.Network.Server2 (RemoteTransitionTrace) -import Ouroboros.Network.Server2 qualified as Server import Ouroboros.Network.Snocket (Snocket, TestAddress (..)) import Ouroboros.Network.Snocket qualified as Snocket @@ -137,7 +137,7 @@ tests = , testProperty "matured peers" prop_inbound_governor_maturedPeers , testProperty "timeouts enforced" prop_timeouts_enforced ] - , testGroup "Server2" + , testGroup "Server" [ testProperty "unidirectional Sim" prop_unidirectional_Sim , testProperty "bidirectional Sim" prop_bidirectional_Sim , testProperty "never above hardlimit" prop_never_above_hardlimit diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Socket.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Socket.hs index be1b414504a..f309432f07b 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Socket.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -50,9 +51,8 @@ import Network.TypedProtocol.ReqResp.Type qualified as ReqResp import Ouroboros.Network.Context import Ouroboros.Network.Driver -import Ouroboros.Network.ErrorPolicy import Ouroboros.Network.IOManager -import Ouroboros.Network.Snocket +import Ouroboros.Network.Snocket as Snocket import Ouroboros.Network.Socket -- TODO: remove Mx prefixes import Ouroboros.Network.Mux @@ -63,11 +63,13 @@ import Network.Mux.Timeout import Network.Mux.Types (MiniProtocolDir (..), RemoteClockModel (..)) import Network.Mux.Types qualified as Mx +import Ouroboros.Network.Protocol.Handshake import Ouroboros.Network.Protocol.Handshake.Codec import Ouroboros.Network.Protocol.Handshake.Unversioned import Ouroboros.Network.Protocol.Handshake.Version import Test.Ouroboros.Network.Orphans () +import Test.Ouroboros.Network.Server qualified as Test.Server import Test.QuickCheck import Test.Tasty (DependencyType (..), TestTree, after, testGroup) @@ -198,7 +200,6 @@ prop_socket_send_recv initiatorAddr responderAddr configureSock f xs = cv <- newEmptyTMVarIO sv <- newEmptyTMVarIO - networkState <- newNetworkMutableState {- The siblingVar is used by the initiator and responder to wait on each other before exiting. - Without this wait there is a risk that one side will finish first causing the Muxbearer to @@ -239,49 +240,44 @@ prop_socket_send_recv initiatorAddr responderAddr configureSock f xs = pure ((), trailing) let snocket = socketSnocket iomgr - res <- - withServerNode - snocket - Mx.makeSocketBearer - ((. Just) <$> configureSock) - networkTracers - networkState - (AcceptedConnectionsLimit maxBound maxBound 0) - responderAddr - unversionedHandshakeCodec - noTimeLimitsHandshake - unversionedProtocolDataCodec - (HandshakeCallbacks acceptableVersion queryVersion) - (unversionedProtocol (SomeResponderApplication responderApp)) - nullErrorPolicies - $ \_ _ -> do - void $ connectToNode - snocket - Mx.makeSocketBearer - ConnectToArgs { - ctaHandshakeCodec = unversionedHandshakeCodec, - ctaHandshakeTimeLimits = noTimeLimitsHandshake, - ctaVersionDataCodec = unversionedProtocolDataCodec, - ctaConnectTracers = NetworkConnectTracers activeMuxTracer nullTracer, - ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion - } - (`configureSock` Nothing) - (unversionedProtocol initiatorApp) - (Just initiatorAddr) - responderAddr - atomically $ (,) <$> takeTMVar sv <*> takeTMVar cv - - return (res == mapAccumL f 0 xs) + bracket (open snocket (Snocket.addrFamily snocket responderAddr)) + (close snocket) $ \sock -> do + bind snocket sock responderAddr + listen snocket sock + res <- + Test.Server.with + snocket + makeSocketBearer + (\fd addr -> configureSock fd (Just addr)) + responderAddr + HandshakeArguments { + haHandshakeTracer = nullTracer, + haHandshakeCodec = unversionedHandshakeCodec, + haVersionDataCodec = unversionedProtocolDataCodec, + haAcceptVersion = acceptableVersion, + haQueryVersion = queryVersion, + haTimeLimits = noTimeLimitsHandshake + } + (unversionedProtocol (SomeResponderApplication responderApp)) + $ \_ _ -> do + void $ connectToNode + snocket + Mx.makeSocketBearer + ConnectToArgs { + ctaHandshakeCodec = unversionedHandshakeCodec, + ctaHandshakeTimeLimits = noTimeLimitsHandshake, + ctaVersionDataCodec = unversionedProtocolDataCodec, + ctaConnectTracers = NetworkConnectTracers activeMuxTracer nullTracer, + ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion + } + (`configureSock` Nothing) + (unversionedProtocol initiatorApp) + (Just initiatorAddr) + responderAddr + atomically $ (,) <$> takeTMVar sv <*> takeTMVar cv + return (res == mapAccumL f 0 xs) where - networkTracers = NetworkServerTracers { - nstMuxTracer = activeMuxTracer, - nstHandshakeTracer = nullTracer, - nstErrorPolicyTracer = showTracing stdoutTracer, - nstAcceptPolicyTracer = nullTracer - } - - waitSibling :: StrictTVar IO Int -> IO () waitSibling cntVar = do atomically $ modifyTVar cntVar (\a -> a - 1) diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Subscription.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Subscription.hs deleted file mode 100644 index fbd0e71d564..00000000000 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Subscription.hs +++ /dev/null @@ -1,957 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-orphans #-} -#if __GLASGOW_HASKELL__ >= 908 -{-# OPTIONS_GHC -Wno-x-partial #-} -#endif - -module Test.Ouroboros.Network.Subscription (tests) where - -import Control.Concurrent hiding (threadDelay) -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad (replicateM, unless, when) -import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime.SI -import Control.Monad.Class.MonadTimer.SI -import Control.Monad.IOSim (runSimStrictShutdown) -import Control.Tracer -import Data.ByteString.Char8 qualified as BSC -import Data.ByteString.Lazy qualified as BL -import Data.Functor (void) -import Data.IP qualified as IP -import Data.List qualified as L -import Data.Map qualified as M -import Data.Void (Void) -import Data.Word -import Network.DNS qualified as DNS -import Network.Socket qualified as Socket -#if !defined(mingw32_HOST_OS) -import Network.Socket.ByteString.Lazy qualified as Socket (recv, sendAll) -#endif - -import Network.Mux qualified as Mx -import Network.Mux.Bearer qualified as Mx ---TODO: time utils should come from elsewhere -import Network.Mux.Time (microsecondsToDiffTime) - -import Network.TypedProtocol.ReqResp.Client qualified as ReqResp -import Network.TypedProtocol.ReqResp.Codec.CBOR qualified as ReqResp -import Network.TypedProtocol.ReqResp.Examples qualified as ReqResp -import Network.TypedProtocol.ReqResp.Server qualified as ReqResp - -import Ouroboros.Network.Protocol.Handshake.Codec -import Ouroboros.Network.Protocol.Handshake.Unversioned -import Ouroboros.Network.Protocol.Handshake.Version - -import Ouroboros.Network.Driver -import Ouroboros.Network.ErrorPolicy -import Ouroboros.Network.IOManager -import Ouroboros.Network.Mux -import Ouroboros.Network.Snocket -import Ouroboros.Network.Socket -import Ouroboros.Network.Subscription -import Ouroboros.Network.Subscription.Dns -import Ouroboros.Network.Subscription.Ip -import Ouroboros.Network.Subscription.PeerState -import Ouroboros.Network.Subscription.Subscriber -import Ouroboros.Network.Subscription.Worker (LocalAddresses (..), - WorkerParams (..)) - -import Test.Ouroboros.Network.Orphans () - -import Test.QuickCheck -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.QuickCheck (testProperty) -import Text.Printf -import Text.Show.Functions () - - -defaultMiniProtocolLimit :: Int -defaultMiniProtocolLimit = 3000000 - -testProtocols1 :: RunMiniProtocolWithMinimalCtx appType addr bytes m a b - -> OuroborosApplicationWithMinimalCtx appType addr bytes m a b -testProtocols1 chainSync = - OuroborosApplication [ - MiniProtocol { - miniProtocolNum = MiniProtocolNum 2, - miniProtocolLimits = MiniProtocolLimits { - maximumIngressQueue = defaultMiniProtocolLimit - }, - miniProtocolRun = chainSync - } - ] - --- | --- Allow to run a singly req-resp protocol. --- -testProtocols2 :: RunMiniProtocolWithMinimalCtx appType addr bytes m a b - -> OuroborosApplicationWithMinimalCtx appType addr bytes m a b -testProtocols2 reqResp = - OuroborosApplication [ - MiniProtocol { - miniProtocolNum = MiniProtocolNum 4, - miniProtocolLimits = MiniProtocolLimits { - maximumIngressQueue = defaultMiniProtocolLimit - }, - miniProtocolRun = reqResp - } - ] - - -activeTracer :: Tracer IO a -activeTracer = nullTracer --- activeTracer = _verboseTracer -- Dump log messages to stdout. - --- --- The list of all tests --- - -tests :: TestTree -tests = - testGroup "Subscription" - [ - testProperty "Resolve (Sim)" prop_resolv_sim - --, testProperty "Resolve (IO)" _prop_resolv_io - -- the above tests takes about 10 minutes to run due to delays in - -- realtime. - , testProperty "Resolve Subscribe (IO)" prop_sub_io - , testProperty "Send Receive with Dns worker (IO)" prop_send_recv - , testProperty "Send Receive with IP worker, Initiator and responder (IO)" - prop_send_recv_init_and_rsp - -- , testProperty "subscription demo" _demo - ] - -data LookupResult = LookupResult { - lrIpv4Result :: !(Either DNS.DNSError [Socket.SockAddr]) - , lrIpv4Delay :: !DiffTime - , lrIpv6Result :: !(Either DNS.DNSError [Socket.SockAddr]) - , lrIpv6Delay :: !DiffTime - , connectionRtt :: !DiffTime - } - -data LookupResultIO = LookupResultIO { - lrioIpv4Result :: !(Either DNS.DNSError [Word16]) - , lrioIpv6Result :: !(Either DNS.DNSError [Word16]) - , lrioFirst :: !Socket.Family - , lrioValency :: !Int - } - -mockResolver :: forall m. MonadDelay m => LookupResult -> Resolver m -mockResolver lr = Resolver lA lAAAA - where - lA :: DNS.Domain -> m (Either DNS.DNSError [Socket.SockAddr]) - lA _ = do - threadDelay (lrIpv4Delay lr) - return $ lrIpv4Result lr - - lAAAA :: DNS.Domain -> m (Either DNS.DNSError [Socket.SockAddr]) - lAAAA _ = do - threadDelay (lrIpv6Delay lr) - return $ lrIpv6Result lr - -withMockResolver :: MonadDelay m - => LookupResult - -> (Resolver m -> m a) - -> m a -withMockResolver lr k = k (mockResolver lr) - - -mockResolverIO :: StrictTMVar IO () - -> M.Map (Socket.Family, Word16) Socket.PortNumber - -> LookupResultIO - -> Resolver IO -mockResolverIO firstDoneMVar portMap lr = Resolver lA lAAAA - where - sidToPort sid = - case M.lookup sid portMap of - Just port -> port - Nothing -> error $ "missing port for sid " ++ show sid -- XXX - - lA :: DNS.Domain -> IO (Either DNS.DNSError [Socket.SockAddr]) - lA _ = do - when (lrioFirst lr == Socket.AF_INET6) $ do - void $ atomically $ takeTMVar firstDoneMVar - threadDelay 0.1 - let r = case lrioIpv4Result lr of - (Right sids) -> Right $ map (\sid -> Socket.SockAddrInet - (sidToPort (Socket.AF_INET, sid)) - (IP.toHostAddress "127.0.0.1")) sids - (Left e) -> Left e - when (lrioFirst lr == Socket.AF_INET) $ - atomically $ putTMVar firstDoneMVar () - return r - - lAAAA :: DNS.Domain -> IO (Either DNS.DNSError [Socket.SockAddr]) - lAAAA _ = do - when (lrioFirst lr == Socket.AF_INET) $ do - void $ atomically $ takeTMVar firstDoneMVar - threadDelay $ 0.1 + resolutionDelay - let r = case lrioIpv6Result lr of - (Right sids) -> Right $ map (\sid -> - Socket.SockAddrInet6 (sidToPort (Socket.AF_INET6, sid)) 0 - (IP.toHostAddress6 "::1") 0) sids - (Left e) -> Left e - when (lrioFirst lr == Socket.AF_INET6) $ - atomically $ putTMVar firstDoneMVar () - return r - -withMockResolverIO :: StrictTMVar IO () - -> M.Map (Socket.Family, Word16) Socket.PortNumber - -> LookupResultIO - -> (Resolver IO -> IO a) - -> IO a -withMockResolverIO firstDoneMVar portMap lr k = k (mockResolverIO firstDoneMVar portMap lr) - -instance Show LookupResult where - show a = printf "LookupResult: ipv4: %s delay %s ipv6: %s delay %s rtt %s" (show $ lrIpv4Result a) - (show $ lrIpv4Delay a) (show $ lrIpv6Result a) (show $ lrIpv6Delay a) - (show $ connectionRtt a) - -instance Show LookupResultIO where - show a = printf "LookupResultIO: ipv4: %s ipv6: %s first %s valency %d" - (show $ lrioIpv4Result a) - (show $ lrioIpv6Result a) - (show $ lrioFirst a) - (lrioValency a) - -instance Arbitrary DNS.DNSError where - arbitrary = oneof [ return DNS.SequenceNumberMismatch - , return DNS.RetryLimitExceeded - ] - -instance Arbitrary IP.IPv4 where - arbitrary = do - a <- replicateM 4 (choose (0,255)) - return $ IP.toIPv4 a - -instance Arbitrary IP.IPv6 where - arbitrary = do - a <- replicateM 8 (choose (0,0xffff)) - return $ IP.toIPv6 a - -instance Arbitrary Socket.Family where - arbitrary = oneof [ return Socket.AF_INET - , return Socket.AF_INET6 - ] - -instance Arbitrary LookupResult where - arbitrary = do - ipv4r <- arbitrary :: Gen (Either DNS.DNSError [IP.IPv4]) - ipv4d <- choose (0, 3000) - ipv6r <- arbitrary - ipv6d <- oneof [ choose (0, 3000) - , choose (ipv4d, ipv4d + round (1000 * resolutionDelay)) - ] - conrtt <- choose (0, 250) - - let minDistance = 10 -- 10ms minimum time between IPv4 and IPv6 result. - - {- - - For predictability we don't generate lookup results that are closer than 10ms to - - each other. Since 10ms is still less than resolutionDelay we can still test that - - behaviour related to resolutionDelay works correctly. - -} - let (ipv4d', ipv6d') = if abs (ipv4d - ipv6d) < minDistance - then if ipv4d > ipv6d then (ipv4d + minDistance, ipv6d) - else (ipv4d, ipv6d + minDistance) - else (ipv4d, ipv6d) - let sa4s = case ipv4r of - (Right ips) -> Right $ map (Socket.SockAddrInet 1 . IP.toHostAddress) ips - (Left e) -> Left e - let sa6s = case ipv6r of - (Right ips) -> Right $ map (\ip -> Socket.SockAddrInet6 1 0 - (IP.toHostAddress6 ip) 0) ips - (Left e) -> Left e - return $ LookupResult sa4s (microsecondsToDiffTime $ 1000 * ipv4d') sa6s - (microsecondsToDiffTime $ 1000 * ipv6d') - (microsecondsToDiffTime $ 1000 * conrtt) - - -instance Arbitrary LookupResultIO where - arbitrary = do - ipv4r <- oneof [ Left <$> arbitrary - , Right <$> shortList - ] - ipv6r <- oneof [ Left <$> arbitrary - , Right <$> shortList - ] - first <- arbitrary - valency <- choose (1, 8) - return $ LookupResultIO ipv4r ipv6r first valency - where - shortList :: Gen [Word16] - shortList = do - lx <- shuffle [0..3] - k <- choose (0, 4) - return $ take k lx - --- | Return true if `a` is a permutation of `b`. -permCheck :: (Ord o, Show o) => [o] -> [o] -> Property -permCheck a b = L.sort a === L.sort b - --- --- Properties --- - -prop_resolv :: forall m. - ( MonadAsync m - , MonadCatch m - , MonadDelay m - , MonadTimer m - ) - => LookupResult - -> m Property -prop_resolv lr = do - --say $ printf "%s" $ show lr - peerStatesVar <- newTVarIO () - x <- dnsResolve nullTracer (return lr) withMockResolver peerStatesVar (\_ _ s -> pure (AllowConnection s)) $ DnsSubscriptionTarget "shelley-1.iohk.example" 1 2 - !res <- checkResult <$> extractResult x [] - - {- - - We wait 100ms here so that the resolveAAAA and resolveA thread have time to - - exit, otherwise runSimStrictShutdown will complain about thread leaks. - - - - Change dnsResolv to return the two Asyncs so we can wait on them? - -} - threadDelay 0.1 - return $ tabulate "Resolution Result" [resolvLabel] res - - where - checkResult :: [Socket.SockAddr] -> Property - checkResult addrs = - case (lrIpv4Result lr, lrIpv6Result lr) of - (Left _, Left _) -> property $ null addrs - - (Right [], Right []) -> property $ null addrs - - (Right ea, Left _) -> - -- Expect a permutation of the result of the A lookup. - permCheck addrs ea - - (Left _, Right ea) -> - -- Expect a permutation of the result of the AAAA lookup. - permCheck addrs ea - - (Right sa4s, Right sa6s) -> - let (cntA, cntB, headFamily) = - if sa4s /= [] && (lrIpv4Delay lr + resolutionDelay < lrIpv6Delay lr - || null sa6s) - then (length sa4s, length sa6s, Socket.AF_INET) - else (length sa6s, length sa4s, Socket.AF_INET6) in - permCheck addrs (sa4s ++ sa6s) .&&. - sockAddrFamily (head addrs) === headFamily .&&. - alternateFamily addrs (sockAddrFamily (head addrs)) True - cntA cntB - - -- Once both the A and the AAAA lookup has returned the result should - -- alternate between the address families until one family is out of addresses. - -- This means that: - -- AAAABABABABABABBB is a valid sequense. - -- AAAABABAAABABABBB is not a valid sequense. - alternateFamily :: [Socket.SockAddr] -> Socket.Family -> Bool -> Int -> Int -> Bool - alternateFamily [] _ _ _ _ = True - alternateFamily _ _ _ (-1) _ = False - alternateFamily _ _ _ _ (-1) = False - alternateFamily (sa:sas) fa True cntA cntB = - if sockAddrFamily sa == fa - then alternateFamily sas fa True (cntA - 1) cntB - else alternateFamily sas (sockAddrFamily sa) False (cntB - 1) cntA - alternateFamily (sa:sas) fa False cntA cntB = - if sockAddrFamily sa == fa - then (cntB == 0) && alternateFamily sas fa False (cntA - 1) cntB - else alternateFamily sas (sockAddrFamily sa) False (cntB - 1) cntA - - extractResult :: SubscriptionTarget m Socket.SockAddr -> [Socket.SockAddr] -> m [Socket.SockAddr] - extractResult targets addrs = do - target_m <- getSubscriptionTarget targets - case target_m of - Just (addr, nextTargets) -> do - threadDelay (connectionRtt lr) - extractResult nextTargets (addr:addrs) - Nothing -> return $ reverse addrs - - resolvLabel :: String - resolvLabel = - case (lrIpv4Result lr, lrIpv6Result lr) of - (Left _, Left _) -> "A and AAAA error" - (Left _, Right []) -> "A error, AAAA no result" - (Left _, Right _) -> "A error, AAAA success" - (Right [], Left _) -> "A error, AAAA no result" - (Right _, Left _) -> "A success, AAAA error" - (Right _, Right _) | lrIpv6Delay lr < lrIpv4Delay lr -> "AAAA before A" - | lrIpv4Delay lr + resolutionDelay > lrIpv6Delay lr -> - "AAAA before A (Resolution Delay)" - | otherwise -> "A before AAAA" - -prop_resolv_sim :: LookupResult -> Property -prop_resolv_sim lr = - case runSimStrictShutdown $ prop_resolv lr of - Left _ -> property False - Right r -> r - -_prop_resolv_io :: LookupResult -> Property -_prop_resolv_io lr = ioProperty $ prop_resolv lr - -prop_sub_io :: LookupResultIO - -> Property -prop_sub_io lr = ioProperty $ withIOManager $ \iocp -> do - let serverIdsv4 = case lrioIpv4Result lr of - Left _ -> [] - Right r -> zip (repeat Socket.AF_INET) r - serverIdsv6 = case lrioIpv6Result lr of - Left _ -> [] - Right r -> zip (repeat Socket.AF_INET6) r - ipv4ClientCount = case lrioIpv4Result lr of - Left _ -> 0 - Right r -> length r - ipv6ClientCount = case lrioIpv6Result lr of - Left _ -> 0 - Right r -> length r - - clientCountVar <- newTVarIO (ipv4ClientCount + ipv6ClientCount) - serverCountVar <- newTVarIO (ipv4ClientCount + ipv6ClientCount) - serverPortMapVar <- newTVarIO M.empty - observerdConnectionOrderVar <- newTVarIO [] - firstDoneVar <- newEmptyTMVarIO - serverWaitVar <- newTVarIO False - - ipv4Servers <- replicateM (length serverIdsv4) (head <$> Socket.getAddrInfo Nothing (Just "127.0.0.1") - (Just "0")) - ipv6Servers <- replicateM (length serverIdsv6) (head <$> Socket.getAddrInfo Nothing (Just "::1") - (Just "0")) - - ipv4Client <- head <$> Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "0") - ipv6Client <- head <$> Socket.getAddrInfo Nothing (Just "::1") (Just "0") - - serverAids <- mapM (async . spawnServer serverCountVar serverPortMapVar - observerdConnectionOrderVar serverWaitVar) $ - zip (serverIdsv4 ++ serverIdsv6) $ ipv4Servers ++ ipv6Servers - - atomically $ do - c <- readTVar serverCountVar - when (c > 0) retry - - serverPortMap <- atomically $ readTVar serverPortMapVar - networkState <- newNetworkMutableState - dnsSubscriptionWorker' - (socketSnocket iocp) - activeTracer - activeTracer - activeTracer - networkState - (return lr) - (withMockResolverIO firstDoneVar serverPortMap) - SubscriptionParams { - spLocalAddresses = - LocalAddresses - (Just $ Socket.addrAddress ipv4Client) - (Just $ Socket.addrAddress ipv6Client) - Nothing, - spConnectionAttemptDelay = const $ Just minConnectionAttemptDelay, - spErrorPolicies = nullErrorPolicies, - spSubscriptionTarget = DnsSubscriptionTarget "shelley-0.iohk.example" 6062 (lrioValency lr) - } - (\_ -> do - c <- readTVar clientCountVar - when (c > 0) retry - writeTVar serverWaitVar True) - (initiatorCallback clientCountVar) - - - mapM_ wait serverAids - - observerdConnectionOrder <- fmap reverse $ atomically $ readTVar observerdConnectionOrderVar - - return $ property $ verifyOrder observerdConnectionOrder - - where - - verifyOrder - :: [(Socket.Family, Word16)] - -> Property - verifyOrder observerdConnectionOrder = - case (lrioIpv4Result lr, lrioIpv6Result lr) of - (Left _, Left _) -> counterexample "null" $ null observerdConnectionOrder - (Right [], Right []) -> counterexample "null" $ null observerdConnectionOrder - (Left _, Right a) -> a === map snd observerdConnectionOrder - (Right a, Left _) -> a === map snd observerdConnectionOrder - (Right a, Right []) -> a === map snd observerdConnectionOrder - (Right [], Right a) -> a === map snd observerdConnectionOrder - (Right r4, Right r6) -> - not (null observerdConnectionOrder) .&&. - (lrioFirst lr === fst (head observerdConnectionOrder)) .&&. - permCheck (r4 ++ r6) (map snd observerdConnectionOrder) - - initiatorCallback - :: StrictTVar IO Int - -> Socket.Socket - -> IO () - initiatorCallback clientCountVar _sd = do -#if !defined(mingw32_HOST_OS) - Socket.sendAll _sd $ BL.singleton 42 - _ <- Socket.recv _sd 1 -#endif - - atomically $ modifyTVar clientCountVar (\a -> a - 1) - - spawnServer serverCountVar serverPortMapVar traceVar stopVar (sid, addr) = - bracket - (Socket.socket (Socket.addrFamily addr) Socket.Stream Socket.defaultProtocol) - Socket.close - (\sd -> do - Socket.setSocketOption sd Socket.ReuseAddr 1 - Socket.bind sd (Socket.addrAddress addr) - localPort <- Socket.socketPort sd - atomically $ modifyTVar serverPortMapVar (M.insert sid localPort) - Socket.listen sd 10 - atomically $ modifyTVar serverCountVar (\a -> a - 1) - bracket - (Socket.accept sd) - (\(sd',_) -> Socket.close sd') - (\(_sd',_) -> do -#if !defined(mingw32_HOST_OS) - buf <- Socket.recv _sd' 1 - Socket.sendAll _sd' buf -#endif - - atomically $ modifyTVar traceVar (\sids -> sid:sids) - atomically $ do - doneWaiting <- readTVar stopVar - unless doneWaiting retry - ) - ) - - -prop_send_recv - :: (Int -> Int -> (Int, Int)) - -> [Int] - -> Socket.Family - -> Property -prop_send_recv f xs _first = ioProperty $ withIOManager $ \iocp -> do - - let first = Socket.AF_INET6 - let lr = LookupResultIO (Right [0]) (Right [0]) first 1 - serverPortMap = M.fromList [((Socket.AF_INET, 0), 6062), ((Socket.AF_INET6, 0), 6062)] - - responderAddr4:_ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "6062") - responderAddr6:_ <- Socket.getAddrInfo Nothing (Just "::1") (Just "6062") - let (responderAddr, faultyAddress) = case first of - Socket.AF_INET -> (responderAddr6, responderAddr4) - Socket.AF_INET6 -> (responderAddr4, responderAddr6) - _ -> error "prop_send_recv: invalid address family" - initiatorAddr4:_ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "0") - initiatorAddr6:_ <- Socket.getAddrInfo Nothing (Just "::1") (Just "0") - - firstDoneVar <- newEmptyTMVarIO - - cv <- newEmptyTMVarIO - sv <- newEmptyTMVarIO - siblingVar <- newTVarIO 2 - tbl <- newConnectionTable - clientTbl <- newConnectionTable - - let -- Server Node; only req-resp server - responderApp :: OuroborosApplicationWithMinimalCtx - Mx.ResponderMode Socket.SockAddr BL.ByteString IO Void () - responderApp = testProtocols2 reqRespResponder - - reqRespResponder = - ResponderProtocolOnly $ - MiniProtocolCb $ \_ctx channel -> do - (r, trailing) <- runPeer (tagTrace "Responder" activeTracer) - ReqResp.codecReqResp - channel - (ReqResp.reqRespServerPeer (ReqResp.reqRespServerMapAccumL (\a -> pure . f a) 0)) - atomically $ putTMVar sv r - ((), trailing) - <$ waitSiblingSub siblingVar - - -- Client Node; only req-resp client - initiatorApp :: OuroborosApplicationWithMinimalCtx - Mx.InitiatorMode Socket.SockAddr BL.ByteString IO () Void - initiatorApp = testProtocols2 reqRespInitiator - - reqRespInitiator = - InitiatorProtocolOnly $ - MiniProtocolCb $ \_ctx channel -> do - (r, trailing) <- runPeer (tagTrace "Initiator" activeTracer) - ReqResp.codecReqResp - channel - (ReqResp.reqRespClientPeer (ReqResp.reqRespClientMap xs)) - atomically $ putTMVar cv r - ((), trailing) <$ - waitSiblingSub siblingVar - - peerStatesVar <- newPeerStatesVar - let sn = socketSnocket iocp - withDummyServer faultyAddress $ - withServerNode - sn - Mx.makeSocketBearer - ((. Just) <$> configureSocket) - nullNetworkServerTracers - (NetworkMutableState tbl peerStatesVar) - (AcceptedConnectionsLimit maxBound maxBound 0) - (Socket.addrAddress responderAddr) - unversionedHandshakeCodec - noTimeLimitsHandshake - unversionedProtocolDataCodec - (HandshakeCallbacks acceptableVersion queryVersion) - (unversionedProtocol (SomeResponderApplication responderApp)) - nullErrorPolicies - $ \_ _ -> do - dnsSubscriptionWorker' - sn activeTracer activeTracer activeTracer - (NetworkMutableState clientTbl peerStatesVar) - (return lr) - (withMockResolverIO firstDoneVar serverPortMap) - SubscriptionParams { - spLocalAddresses = - LocalAddresses - (Just $ Socket.addrAddress initiatorAddr4) - (Just $ Socket.addrAddress initiatorAddr6) - Nothing, - spConnectionAttemptDelay = \_ -> Just minConnectionAttemptDelay, - spErrorPolicies = nullErrorPolicies, - spSubscriptionTarget = DnsSubscriptionTarget "shelley-0.iohk.example" 6062 1 - } - (\_ -> waitSiblingSTM siblingVar) - (connectToNodeSocket - iocp - ConnectToArgs { - ctaHandshakeCodec = unversionedHandshakeCodec, - ctaHandshakeTimeLimits = noTimeLimitsHandshake, - ctaVersionDataCodec = unversionedProtocolDataCodec, - ctaConnectTracers = nullNetworkConnectTracers, - ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion - } - (unversionedProtocol initiatorApp)) - - res <- atomically $ (,) <$> takeTMVar sv <*> takeTMVar cv - return (res == L.mapAccumL f 0 xs) - - where - withDummyServer :: Socket.AddrInfo - -> IO a - -> IO a - withDummyServer addr k = - bracket - (Socket.socket (Socket.addrFamily addr) Socket.Stream Socket.defaultProtocol) - Socket.close - (\sd -> do - -- bind the socket, so that it is used, but don't listen to it. - Socket.setSocketOption sd Socket.ReuseAddr 1 - Socket.bind sd (Socket.addrAddress addr) - k - ) - - -data ReqRspCfg = ReqRspCfg { - rrcTag :: !String - , rrcServerVar :: !(StrictTMVar IO Int) - , rrcClientVar :: !(StrictTMVar IO [Int]) - , rrcSiblingVar :: !(StrictTVar IO Int) -} - -newReqRspCfg :: String -> StrictTVar IO Int -> IO ReqRspCfg -newReqRspCfg tag siblingVar = do - sv <- newEmptyTMVarIO - cv <- newEmptyTMVarIO - return $ ReqRspCfg tag sv cv siblingVar - -prop_send_recv_init_and_rsp - :: (Int -> Int -> (Int, Int)) - -> [Int] - -> Property -prop_send_recv_init_and_rsp f xs = ioProperty $ withIOManager $ \iocp -> do - - responderAddr4A:_ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "0") - responderAddr4B:_ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "0") - - addrAVar <- newEmptyTMVarIO - addrBVar <- newEmptyTMVarIO - - siblingVar <- newTVarIO 4 - {- 4 comes from one initiator and responder running on the server and one initiator and - - and responder running on the client. - -} - - tblA <- newConnectionTable - tblB <- newConnectionTable - - rrcfgA <- newReqRspCfg "A" siblingVar - rrcfgB <- newReqRspCfg "B" siblingVar - - stVar <- newPeerStatesVar - - a_aid <- async $ startPassiveServer - iocp - tblA - stVar - (Socket.addrAddress responderAddr4A) - addrAVar - rrcfgA - - b_aid <- async $ startActiveServer - iocp - tblB - stVar - (Socket.addrAddress responderAddr4B) - addrBVar - addrAVar - rrcfgB - - (resA, resB) <- waitBoth a_aid b_aid - return $ (resA == L.mapAccumL f 0 xs) && (resB == L.mapAccumL f 0 xs) - - where - - appX :: ReqRspCfg - -> OuroborosApplicationWithMinimalCtx - Mx.InitiatorResponderMode Socket.SockAddr BL.ByteString IO () () - appX cfg = testProtocols2 (reqResp cfg) - - reqResp ReqRspCfg {rrcTag, rrcServerVar, rrcClientVar, rrcSiblingVar} = - InitiatorAndResponderProtocol - -- Initiator - (MiniProtocolCb $ \_ctx channel -> do - (r, trailing) <- runPeer (tagTrace (rrcTag ++ " Initiator") activeTracer) - ReqResp.codecReqResp - channel - (ReqResp.reqRespClientPeer (ReqResp.reqRespClientMap xs)) - atomically $ putTMVar rrcClientVar r - -- wait for our responder and peer - ((), trailing) - <$ waitSiblingSub rrcSiblingVar - ) - -- Responder - (MiniProtocolCb $ \_ctx channel -> do - (r, trailing) <- runPeer (tagTrace (rrcTag ++ " Responder") activeTracer) - ReqResp.codecReqResp - channel - (ReqResp.reqRespServerPeer (ReqResp.reqRespServerMapAccumL - (\a -> pure . f a) 0)) - atomically $ putTMVar rrcServerVar r - -- wait for our initiator and peer - ((), trailing) - <$ waitSiblingSub rrcSiblingVar - ) - - startPassiveServer iocp tbl stVar responderAddr localAddrVar rrcfg = withServerNode - (socketSnocket iocp) - Mx.makeSocketBearer - ((. Just) <$> configureSocket) - nullNetworkServerTracers - (NetworkMutableState tbl stVar) - (AcceptedConnectionsLimit maxBound maxBound 0) - responderAddr - unversionedHandshakeCodec - noTimeLimitsHandshake - unversionedProtocolDataCodec - (HandshakeCallbacks acceptableVersion queryVersion) - (unversionedProtocol (SomeResponderApplication (appX rrcfg))) - nullErrorPolicies - $ \localAddr _ -> do - atomically $ putTMVar localAddrVar localAddr - r <- atomically $ (,) <$> takeTMVar (rrcServerVar rrcfg) - <*> takeTMVar (rrcClientVar rrcfg) - waitSibling (rrcSiblingVar rrcfg) - return r - - startActiveServer iocp tbl stVar responderAddr localAddrVar remoteAddrVar rrcfg = - let sn = socketSnocket iocp - in withServerNode - sn - Mx.makeSocketBearer - ((. Just) <$> configureSocket) - nullNetworkServerTracers - (NetworkMutableState tbl stVar) - (AcceptedConnectionsLimit maxBound maxBound 0) - responderAddr - unversionedHandshakeCodec - noTimeLimitsHandshake - unversionedProtocolDataCodec - (HandshakeCallbacks acceptableVersion queryVersion) - (unversionedProtocol (SomeResponderApplication (appX rrcfg))) - nullErrorPolicies - $ \localAddr _ -> do - peerStatesVar <- newPeerStatesVar - atomically $ putTMVar localAddrVar localAddr - remoteAddr <- atomically $ takeTMVar remoteAddrVar - _ <- subscriptionWorker - sn - activeTracer - activeTracer - (NetworkMutableState tbl peerStatesVar) - WorkerParams { - wpLocalAddresses = LocalAddresses (Just localAddr) Nothing Nothing, - wpSelectAddress = selectSockAddr, - wpConnectionAttemptDelay = \_ -> Just minConnectionAttemptDelay, - wpSubscriptionTarget = pure $ listSubscriptionTarget [remoteAddr], - wpValency = 1 - } - nullErrorPolicies - (\_ -> waitSiblingSTM (rrcSiblingVar rrcfg)) - (connectToNodeSocket - iocp - ConnectToArgs { - ctaHandshakeCodec = unversionedHandshakeCodec, - ctaHandshakeTimeLimits = noTimeLimitsHandshake, - ctaVersionDataCodec = unversionedProtocolDataCodec, - ctaConnectTracers = nullNetworkConnectTracers, - ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion - } - (unversionedProtocol (appX rrcfg))) - - atomically $ (,) <$> takeTMVar (rrcServerVar rrcfg) - <*> takeTMVar (rrcClientVar rrcfg) - -waitSiblingSub :: StrictTVar IO Int -> IO () -waitSiblingSub cntVar = do - atomically $ modifyTVar cntVar (\a -> a - 1) - waitSibling cntVar - -waitSiblingSTM :: StrictTVar IO Int -> STM IO () -waitSiblingSTM cntVar = do - cnt <- readTVar cntVar - unless (cnt == 0) retry - -waitSibling :: StrictTVar IO Int -> IO () -waitSibling = atomically . waitSiblingSTM - -{- - - XXX Doesn't really test anything, doesn't exit in a resonable time. - - XXX Depends on external network config - - unbound DNS config example: -local-data: "shelley-1.iohk.example. IN A 192.168.1.115" -local-data: "shelley-1.iohk.example. IN A 192.168.1.215" -local-data: "shelley-1.iohk.example. IN A 192.168.1.216" -local-data: "shelley-1.iohk.example. IN A 192.168.1.100" -local-data: "shelley-1.iohk.example. IN A 192.168.1.101" -local-data: "shelley-1.iohk.example. IN A 127.0.0.1" -local-data: "shelley-1.iohk.example. IN AAAA ::1" - -local-data: "shelley-0.iohk.example. IN AAAA ::1" --} -_demo :: Property -_demo = ioProperty $ withIOManager $ \iocp -> do - server:_ <- Socket.getAddrInfo Nothing (Just "192.168.1.100") (Just "6062") - server':_ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "6062") - server6:_ <- Socket.getAddrInfo Nothing (Just "::1") (Just "6062") - server6':_ <- Socket.getAddrInfo Nothing (Just "::1") (Just "6064") - client:_ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "0") - client6:_ <- Socket.getAddrInfo Nothing (Just "::1") (Just "0") - - tbl <- newConnectionTable - clientTbl <- newConnectionTable - peerStatesVar <- newPeerStatesVar - stVar <- newPeerStatesVar - - spawnServer iocp tbl stVar server 10000 - spawnServer iocp tbl stVar server' 10000 - spawnServer iocp tbl stVar server6 100 - spawnServer iocp tbl stVar server6' 45 - - _ <- dnsSubscriptionWorker - (socketSnocket iocp) - activeTracer activeTracer activeTracer - (NetworkMutableState clientTbl peerStatesVar) - SubscriptionParams { - spLocalAddresses = - LocalAddresses - (Just $ Socket.addrAddress client) - (Just $ Socket.addrAddress client6) - Nothing, - spConnectionAttemptDelay = \_ -> Just minConnectionAttemptDelay, - spSubscriptionTarget = DnsSubscriptionTarget "shelley-0.iohk.example" 6064 1, - spErrorPolicies = nullErrorPolicies - - } - (connectToNodeSocket - iocp - ConnectToArgs { - ctaHandshakeCodec = unversionedHandshakeCodec, - ctaHandshakeTimeLimits = noTimeLimitsHandshake, - ctaVersionDataCodec = unversionedProtocolDataCodec, - ctaConnectTracers = nullNetworkConnectTracers, - ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion - } - (unversionedProtocol appReq)) - - threadDelay 130 - -- bring the servers back again - spawnServer iocp tbl stVar server6 10000 - spawnServer iocp tbl stVar server6' 10000 - threadDelay 1000 - return () - - where - - spawnServer iocp tbl stVar addr delay = - void $ async $ withServerNode - (socketSnocket iocp) - Mx.makeSocketBearer - ((. Just) <$> configureSocket) - nullNetworkServerTracers - (NetworkMutableState tbl stVar) - (AcceptedConnectionsLimit maxBound maxBound 0) - (Socket.addrAddress addr) - unversionedHandshakeCodec - noTimeLimitsHandshake - unversionedProtocolDataCodec - (HandshakeCallbacks acceptableVersion queryVersion) - (unversionedProtocol (SomeResponderApplication appRsp)) - nullErrorPolicies - (\_ _ -> threadDelay delay) - - - appReq = - testProtocols1 $ - InitiatorProtocolOnly $ - MiniProtocolCb $ \_ _ -> error "req fail" - - appRsp = - testProtocols1 $ - ResponderProtocolOnly $ - MiniProtocolCb $ \_ _ -> error "rsp fail" - -data WithThreadAndTime a = WithThreadAndTime { - wtatOccuredAt :: !UTCTime - , wtatWithinThread :: !ThreadId - , wtatEvent :: !a - } - -instance (Show a) => Show (WithThreadAndTime a) where - show WithThreadAndTime {wtatOccuredAt, wtatWithinThread, wtatEvent} = - printf "%s: %s: %s" (show wtatOccuredAt) (show wtatWithinThread) (show wtatEvent) - -_verboseTracer :: Show a => Tracer IO a -_verboseTracer = threadAndTimeTracer $ Tracer (BSC.putStrLn . BSC.pack . show) - -threadAndTimeTracer :: Tracer IO (WithThreadAndTime a) -> Tracer IO a -threadAndTimeTracer tr = Tracer $ \s -> do - !now <- getCurrentTime - !tid <- myThreadId - traceWith tr $ WithThreadAndTime now tid s - -data WithTag a = WithTag { - wtTag :: !String - , wtEvent :: !a - } - -instance (Show a) => Show (WithTag a) where - show WithTag {wtTag, wtEvent} = - printf "%s: %s" wtTag (show wtEvent) - -tagTrace :: String -> Tracer IO (WithTag a) -> Tracer IO a -tagTrace tag tr = Tracer $ \s -> traceWith tr $ WithTag tag s diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ErrorPolicy.hs b/ouroboros-network-framework/src/Ouroboros/Network/ErrorPolicy.hs deleted file mode 100644 index 518f243208c..00000000000 --- a/ouroboros-network-framework/src/Ouroboros/Network/ErrorPolicy.hs +++ /dev/null @@ -1,328 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | Error policies, and integration with 'SuspendDecision'-semigroup action on --- 'PeerState'. --- -module Ouroboros.Network.ErrorPolicy - ( ErrorPolicies (..) - , nullErrorPolicies - , ErrorPolicy (..) - , evalErrorPolicy - , evalErrorPolicies - , CompleteApplication - , CompleteApplicationResult (..) - , Result (..) - , completeApplicationTx - -- * Traces - , ErrorPolicyTrace (..) - , traceErrorPolicy - , WithAddr (..) - -- * Re-exports of PeerState - , PeerStates - , SuspendDecision (..) - ) where - -import Control.Exception (Exception, IOException, SomeException (..)) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Map.Strict qualified as Map -import Data.Maybe (mapMaybe) -import Data.Semigroup (sconcat) -import Data.Set (Set) -import Data.Set qualified as Set -import Data.Typeable (Proxy (..), cast, tyConName, typeRep, typeRepTyCon) -import Text.Printf - -import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadSTM -import Control.Monad.Class.MonadTime.SI - -import Ouroboros.Network.Subscription.PeerState - -data ErrorPolicy where - ErrorPolicy :: forall e. - Exception e - => (e -> Maybe (SuspendDecision DiffTime)) - -- ^ @Nothing@ means no decision. It is equivalent to not - -- having the policy at all. In 'evalErrorPolicies' this will - -- fall-through and match against the remaining policies. - -> ErrorPolicy - -instance Show ErrorPolicy where - show (ErrorPolicy (_err :: e -> Maybe (SuspendDecision DiffTime))) = - "ErrorPolicy (" - ++ tyConName (typeRepTyCon (typeRep (Proxy :: Proxy e))) - ++ ")" - - -evalErrorPolicy :: forall e. - Exception e - => e - -> ErrorPolicy - -> Maybe (SuspendDecision DiffTime) -evalErrorPolicy e p = - case p of - ErrorPolicy (f :: e' -> Maybe (SuspendDecision DiffTime)) - -> case cast e :: Maybe e' of - Nothing -> Nothing - Just e' -> f e' - --- | Evaluate a list of 'ErrorPolicy's; If none of them applies this function --- returns 'Nothing', in this case the exception will be traced and not thrown. --- -evalErrorPolicies :: forall e. - Exception e - => e - -> [ErrorPolicy] - -> Maybe (SuspendDecision DiffTime) -evalErrorPolicies e = - f . mapMaybe (evalErrorPolicy e) - where - f :: [SuspendDecision DiffTime] - -> Maybe (SuspendDecision DiffTime) - f [] = Nothing - f (cmd : rst) = Just $ sconcat (cmd :| rst) - - --- | List of error policies for exception handling and a policy for handing --- application return values. --- -data ErrorPolicies = ErrorPolicies { - -- | Application Error Policies - epAppErrorPolicies :: [ErrorPolicy] - -- | `connect` Error Policies - , epConErrorPolicies :: [ErrorPolicy] - } - -nullErrorPolicies :: ErrorPolicies -nullErrorPolicies = ErrorPolicies [] [] - -instance Semigroup ErrorPolicies where - ErrorPolicies aep cep <> ErrorPolicies aep' cep' - = ErrorPolicies (aep <> aep') (cep <> cep') - --- | Sum type which distinguishes between connection and application --- exception traces. --- -data ConnectionOrApplicationExceptionTrace err = - -- | Trace of exception thrown by `connect` - ConnectionExceptionTrace err - -- | Trace of exception thrown by an application - | ApplicationExceptionTrace err - deriving (Show, Functor) - - --- | Complete a connection, which receive application result (or exception). --- -type CompleteApplication m s addr r = - Result addr r -> s -> STM m (CompleteApplicationResult m addr s) - - --- | Result of the connection thread. It's either result of an application, or --- an exception thrown by it. --- -data Result addr r where - ApplicationResult - :: !Time - -> !addr - -> !r - -> Result addr r - - Connected - :: !Time - -> !addr - -> Result addr r - - ConnectionError - :: Exception e - => !Time - -> !addr - -> !e - -> Result addr r - - ApplicationError - :: Exception e - => !Time - -> !addr - -> !e - -> Result addr r - - -data CompleteApplicationResult m addr s = - CompleteApplicationResult { - carState :: !s, - -- ^ new state - carThreads :: Set (Async m ()), - -- ^ threads to kill - carTrace :: Maybe (WithAddr addr ErrorPolicyTrace) - -- ^ trace points - } - deriving Functor - - --- | 'CompleteApplication' callback --- -completeApplicationTx - :: forall m addr a. - ( MonadAsync m - , Ord addr - , Ord (Async m ()) - ) - => ErrorPolicies - -> CompleteApplication m - (PeerStates m addr) - addr - a - --- the 'ResultQ' did not throw the exception yet; it should not happen. -completeApplicationTx _ _ ps@ThrowException{} = pure $ - CompleteApplicationResult { - carState = ps, - carThreads = Set.empty, - carTrace = Nothing - } - --- application returned; classify the return value and update the state. -completeApplicationTx _ ApplicationResult{} ps = - pure $ CompleteApplicationResult { - carState = ps, - carThreads = Set.empty, - carTrace = Nothing - } - --- application errored -completeApplicationTx ErrorPolicies {epAppErrorPolicies} (ApplicationError t addr e) ps = - case evalErrorPolicies e epAppErrorPolicies of - -- the error is not handled by any policy; we're not rethrowing the - -- error from the main thread, we only trace it. This will only kill - -- the local consumer application. - Nothing -> pure $ - CompleteApplicationResult { - carState = ps, - carThreads = Set.empty, - carTrace = Just - (WithAddr addr - (ErrorPolicyUnhandledApplicationException - (SomeException e))) - } - -- the error was classified; act with the 'SuspendDecision' on the state - -- and find threads to cancel. - Just cmd -> case runSuspendDecision t addr e cmd ps of - (ps', threads) -> - pure $ - CompleteApplicationResult { - carState = ps', - carThreads = threads, - carTrace = WithAddr addr <$> - traceErrorPolicy - (Left $ ApplicationExceptionTrace (SomeException e)) - cmd - } - --- we connected to a peer; this does not require to update the 'PeerState'. -completeApplicationTx _ (Connected _t _addr) ps = - pure $ - CompleteApplicationResult { - carState = ps, - carThreads = Set.empty, - carTrace = Nothing - } - --- error raised by the 'connect' call -completeApplicationTx ErrorPolicies {epConErrorPolicies} (ConnectionError t addr e) ps = - case evalErrorPolicies e epConErrorPolicies of - Nothing -> - let fn p@(HotPeer producers consumers) - | Set.null producers && Set.null consumers - = Just ColdPeer - | otherwise - = Just p - fn p = Just p - - in pure $ - CompleteApplicationResult { - carState = - case ps of - PeerStates peerStates -> PeerStates $ Map.update fn addr peerStates -#if __GLASGOW_HASKELL__ < 900 - -- GHC 9 is certain this pattern is - -- not used. GHC 8 apparently can't - -- agree. m( - ThrowException{} -> ps -#endif - , carThreads = Set.empty - , carTrace = Just $ - WithAddr addr - (ErrorPolicyUnhandledConnectionException - (SomeException e)) - } - Just cmd -> case runSuspendDecision t addr e cmd ps of - (ps', threads) -> - pure $ - CompleteApplicationResult { - carState = ps', - carThreads = threads, - carTrace = WithAddr addr <$> - (traceErrorPolicy - (Left $ ConnectionExceptionTrace (SomeException e)) - cmd) - } - --- --- Traces --- - --- | Trace data for error policies -data ErrorPolicyTrace - = ErrorPolicySuspendPeer (Maybe (ConnectionOrApplicationExceptionTrace SomeException)) DiffTime DiffTime - -- ^ suspending peer with a given exception until - | ErrorPolicySuspendConsumer (Maybe (ConnectionOrApplicationExceptionTrace SomeException)) DiffTime - -- ^ suspending consumer until - | ErrorPolicyLocalNodeError (ConnectionOrApplicationExceptionTrace SomeException) - -- ^ caught a local exception - | ErrorPolicyResumePeer - -- ^ resume a peer (both consumer and producer) - | ErrorPolicyKeepSuspended - -- ^ consumer was suspended until producer will resume - | ErrorPolicyResumeConsumer - -- ^ resume consumer - | ErrorPolicyResumeProducer - -- ^ resume producer - | ErrorPolicyUnhandledApplicationException SomeException - -- ^ an application throwed an exception, which was not handled by any - -- 'ErrorPolicy'. - | ErrorPolicyUnhandledConnectionException SomeException - -- ^ 'connect' throwed an exception, which was not handled by any - -- 'ErrorPolicy'. - | ErrorPolicyAcceptException IOException - -- ^ 'accept' throwed an exception - deriving Show - -traceErrorPolicy :: Either (ConnectionOrApplicationExceptionTrace SomeException) r - -> SuspendDecision DiffTime - -> Maybe ErrorPolicyTrace -traceErrorPolicy (Left e) (SuspendPeer prodT consT) = - Just $ ErrorPolicySuspendPeer (Just e) prodT consT -traceErrorPolicy (Right _) (SuspendPeer prodT consT) = - Just $ ErrorPolicySuspendPeer Nothing prodT consT -traceErrorPolicy (Left e) (SuspendConsumer consT) = - Just $ ErrorPolicySuspendConsumer (Just e) consT -traceErrorPolicy (Right _) (SuspendConsumer consT) = - Just $ ErrorPolicySuspendConsumer Nothing consT -traceErrorPolicy (Left e) Throw = - Just $ ErrorPolicyLocalNodeError e -traceErrorPolicy _ _ = - Nothing - -data WithAddr addr a = WithAddr { - wiaAddr :: addr - , wiaEvent :: a - } - -instance (Show addr, Show a) => Show (WithAddr addr a) where - show WithAddr { wiaAddr, wiaEvent } = - printf "IP %s %s" (show wiaAddr) (show wiaEvent) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake.hs b/ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake.hs index 70997136aa4..c9e25dbda46 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake.hs @@ -48,6 +48,9 @@ handshakeProtocolNum = Mx.MiniProtocolNum 0 -- | Wrapper around initiator and responder errors experienced by tryHandshake. -- +-- TODO: should we have `Exception` instance? +-- It would be handly in `prop_socket_send_recgtv`. +-- data HandshakeException vNumber = HandshakeProtocolLimit ProtocolLimitFailure | HandshakeProtocolError (HandshakeProtocolError vNumber) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Server2.hs b/ouroboros-network-framework/src/Ouroboros/Network/Server.hs similarity index 99% rename from ouroboros-network-framework/src/Ouroboros/Network/Server2.hs rename to ouroboros-network-framework/src/Ouroboros/Network/Server.hs index f8d65d40842..e84de512686 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Server2.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Server.hs @@ -15,7 +15,7 @@ -- -- This module should be imported qualified. -- -module Ouroboros.Network.Server2 +module Ouroboros.Network.Server ( Arguments (..) -- * Run server , with diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Server/Socket.hs b/ouroboros-network-framework/src/Ouroboros/Network/Server/Socket.hs deleted file mode 100644 index 06ec7f03629..00000000000 --- a/ouroboros-network-framework/src/Ouroboros/Network/Server/Socket.hs +++ /dev/null @@ -1,310 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} - --- `accept` is shadowed, but so what? -{-# OPTIONS_GHC "-fno-warn-name-shadowing" #-} - -module Ouroboros.Network.Server.Socket - ( AcceptedConnectionsLimit (..) - , AcceptConnectionsPolicyTrace (..) - , BeginConnection - , HandleConnection (..) - , ApplicationStart - , CompleteConnection - , CompleteApplicationResult (..) - , Result (..) - , Main - , run - , Socket (..) - , ioSocket - ) where - -import Control.Concurrent.Async (Async) -import Control.Concurrent.Async qualified as Async -import Control.Concurrent.STM (STM) -import Control.Concurrent.STM qualified as STM -import Control.Exception (IOException, SomeException (..), finally, mask, mask_, - onException, try) -import Control.Monad (forM_, join) -import Control.Monad.Class.MonadTime.SI (Time, getMonotonicTime) -import Control.Monad.Class.MonadTimer.SI (threadDelay) -import Control.Tracer (Tracer, traceWith) -import Data.Foldable (traverse_) -import Data.Set (Set) -import Data.Set qualified as Set - -import Ouroboros.Network.ErrorPolicy (CompleteApplicationResult (..), - ErrorPolicyTrace, WithAddr) -import Ouroboros.Network.Server.RateLimiting - --- | Abstraction of something that can provide connections. --- A `Network.Socket` can be used to get a --- `Socket SockAddr (Channel IO Lazy.ByteString)` --- It's not defined in here, though, because we don't want the dependency --- on typed-protocols or even on network. -data Socket addr channel = Socket - { acceptConnection :: IO (addr, channel, IO (), Socket addr channel) - -- ^ The address, a channel, IO to close the channel. - } - --- | Expected to be useful for testing. -ioSocket :: IO (addr, channel) -> Socket addr channel -ioSocket io = Socket - { acceptConnection = do - (addr, channel) <- io - pure (addr, channel, pure (), ioSocket io) - } - -type StatusVar st = STM.TVar st - - --- | What to do with a new connection: reject it and give a new state, or --- accept it and give a new state with a continuation to run against the --- resulting channel. --- See also `CompleteConnection`, which is run for every connection when it finishes, and --- can also update the state. -data HandleConnection channel st r where - Reject :: !st -> HandleConnection channel st r - Accept :: !st -> !(channel -> IO r) -> HandleConnection channel st r - --- | What to do on a new connection: accept and run this `IO`, or reject. -type BeginConnection addr channel st r = Time -> addr -> st -> STM (HandleConnection channel st r) - --- | A call back which runs when application starts; --- --- It is needed only because 'BeginConnection' does not have access to the --- thread which runs the application. --- -type ApplicationStart addr st = addr -> Async () -> st -> STM st - --- | How to update state when a connection finishes. Can use `throwSTM` to --- terminate the server. --- --- TODO: remove 'async', use `Async m ()` from 'MonadAsync'. -type CompleteConnection addr st tr r = - Result addr r -> st -> STM (CompleteApplicationResult IO addr st) - --- | Given a current state, `retry` unless you want to stop the server. --- When this transaction returns, any running threads spawned by the server --- will be killed. --- --- It's possible that a connection is accepted after the main thread --- returns, but before the server stops. In that case, it will be killed, and --- the `CompleteConnection` will not run against it. -type Main st t = st -> STM t - --- | To avoid repeatedly blocking on the set of all running threads (a --- potentially very large STM transaction) the results come in by way of a --- `TQueue`. Using a queue rather than, say, a `TMVar`, also finesses a --- potential deadlock when shutting down the server and killing spawned threads: --- the server can stop pulling from the queue, without causing the child --- threads to hang attempting to write to it. -type ResultQ addr r = STM.TQueue (Result addr r) - --- | The product of a spawned thread. We catch all (even async) exceptions. -data Result addr r = Result - { resultThread :: !(Async ()) - , resultAddr :: !addr - , resultTime :: !Time - , resultValue :: !(Either SomeException r) - } - --- | The set of all spawned threads. Used for waiting or cancelling them when --- the server shuts down. -type ThreadsVar = STM.TVar (Set (Async ())) - - --- | The action runs inside `try`, and when it finishes, puts its result --- into the `ResultQ`. Takes care of inserting/deleting from the `ThreadsVar`. --- --- Async exceptions are masked to ensure that if the thread is spawned, it --- always gets into the `ThreadsVar`. Exceptions are unmasked in the --- spawned thread. -spawnOne - :: addr - -> StatusVar st - -> ResultQ addr r - -> ThreadsVar - -> ApplicationStart addr st - -> IO r - -> IO () -spawnOne remoteAddr statusVar resQ threadsVar applicationStart io = mask_ $ do - rec let threadAction = \unmask -> do - STM.atomically $ - STM.readTVar statusVar - >>= applicationStart remoteAddr thread - >>= (STM.writeTVar statusVar $!) - val <- try (unmask io) - t <- getMonotonicTime - -- No matter what the exception, async or sync, this will not - -- deadlock, since we use a `TQueue`. If the server kills its - -- children, and stops clearing the queue, it will be collected - -- shortly thereafter, so no problem. - STM.atomically $ STM.writeTQueue resQ (Result thread remoteAddr t val) - thread <- Async.asyncWithUnmask $ \unmask -> - threadAction unmask - -- The main loop `connectionTx` will remove this entry from the set, once - -- it receives the result. - STM.atomically $ STM.modifyTVar' threadsVar (Set.insert thread) - - --- | The accept thread is controlled entirely by the `accept` call. To --- stop it, whether normally or exceptionally, it must be killed by an async --- exception, or the exception callback here must re-throw. -acceptLoop - :: Tracer IO AcceptConnectionsPolicyTrace - -> ResultQ addr r - -> ThreadsVar - -> StatusVar st - -> AcceptedConnectionsLimit - -> BeginConnection addr channel st r - -> ApplicationStart addr st - -> (IOException -> IO ()) -- ^ Exception on `Socket.accept`. - -> Socket addr channel - -> IO () -acceptLoop acceptPolicyTrace resQ threadsVar statusVar acceptedConnectionLimit beginConnection applicationStart acceptException socket = do - mNextSocket <- acceptOne acceptPolicyTrace resQ threadsVar statusVar acceptedConnectionLimit beginConnection applicationStart acceptException socket - case mNextSocket of - Nothing -> do - -- Thread delay to mitigate potential livelock. - threadDelay 0.5 - acceptLoop acceptPolicyTrace resQ threadsVar statusVar acceptedConnectionLimit beginConnection applicationStart acceptException socket - Just nextSocket -> - acceptLoop acceptPolicyTrace resQ threadsVar statusVar acceptedConnectionLimit beginConnection applicationStart acceptException nextSocket - --- | Accept once from the socket, use the `Accept` to make a decision (accept --- or reject), and spawn the thread if accepted. -acceptOne - :: forall addr channel st r. - Tracer IO AcceptConnectionsPolicyTrace - -> ResultQ addr r - -> ThreadsVar - -> StatusVar st - -> AcceptedConnectionsLimit - -> BeginConnection addr channel st r - -> ApplicationStart addr st - -> (IOException -> IO ()) -- ^ Exception on `Socket.accept`. - -> Socket addr channel - -> IO (Maybe (Socket addr channel)) -acceptOne acceptPolicyTrace resQ threadsVar statusVar acceptedConnectionsLimit beginConnection applicationStart acceptException socket = mask $ \restore -> do - - -- Rate limiting of accepted connections; this might block. - runConnectionRateLimits - acceptPolicyTrace - (Set.size <$> STM.readTVar threadsVar) - acceptedConnectionsLimit - - -- mask is to assure that every socket is closed. - outcome <- try (restore (acceptConnection socket)) - case outcome :: Either IOException (addr, channel, IO (), Socket addr channel) of - Left ex -> do - -- Classify the exception, if it is fatal to the node or not. - -- If it is fatal to the node the exception will propagate. - restore (acceptException ex) - pure Nothing - Right (addr, channel, close, nextSocket) -> do - -- Decide whether to accept or reject, using the current state, and - -- update it according to the decision. - t <- getMonotonicTime - let decision = STM.atomically $ do - st <- STM.readTVar statusVar - !handleConn <- beginConnection t addr st - case handleConn of - Reject st' -> do - STM.writeTVar statusVar st' - pure Nothing - Accept st' io -> do - STM.writeTVar statusVar st' - pure $ Just io - -- this could be interrupted, so we use `onException` to close the - -- socket. - choice <- decision `onException` close - case choice of - Nothing -> close - Just io -> spawnOne addr statusVar resQ threadsVar applicationStart (io channel `finally` close) - pure (Just nextSocket) - --- | Main server loop, which runs alongside the `acceptLoop`. It waits for --- the results of connection threads, as well as the `Main` action, which --- determines when/if the server should stop. -mainLoop - :: forall addr st tr r t . - Tracer IO (WithAddr addr ErrorPolicyTrace) - -> ResultQ addr r - -> ThreadsVar - -> StatusVar st - -> CompleteConnection addr st tr r - -> Main st t - -> IO t -mainLoop errorPolicyTrace resQ threadsVar statusVar complete main = - join (STM.atomically $ mainTx `STM.orElse` connectionTx) - - where - - -- Sample the status, and run the main action. If it does not retry, then - -- the `mainLoop` finishes with `pure t` where `t` is the main action result. - mainTx :: STM (IO t) - mainTx = do - st <- STM.readTVar statusVar - t <- main st - pure $ pure t - - -- Wait for some connection to finish, update the state with its result, - -- then recurse onto `mainLoop`. - connectionTx :: STM (IO t) - connectionTx = do - result <- STM.readTQueue resQ - -- Make sure we don't cleanup before spawnOne has inserted the thread - isMember <- Set.member (resultThread result) <$> STM.readTVar threadsVar - STM.check isMember - - st <- STM.readTVar statusVar - CompleteApplicationResult - { carState - , carThreads - , carTrace - } <- complete result st - -- 'CompleteConnectionResult' is strict in 'ccrState', thus we write - -- evaluted state to 'statusVar' - STM.writeTVar statusVar carState - -- It was inserted by `spawnOne`. - STM.modifyTVar' threadsVar (Set.delete (resultThread result)) - pure $ do - traverse_ Async.cancel carThreads - traverse_ (traceWith errorPolicyTrace) carTrace - mainLoop errorPolicyTrace resQ threadsVar statusVar complete main - - --- | Run a server. -run - :: Tracer IO (WithAddr addr ErrorPolicyTrace) - -> Tracer IO AcceptConnectionsPolicyTrace - -- TODO: extend this trace to trace server action (this might be useful for - -- debugging) - -> Socket addr channel - -> AcceptedConnectionsLimit - -> (IOException -> IO ()) - -> BeginConnection addr channel st r - -> ApplicationStart addr st - -> CompleteConnection addr st tr r - -> Main st t - -> STM.TVar st - -> IO t -run errroPolicyTrace acceptPolicyTrace socket acceptedConnectionLimit acceptException beginConnection applicationStart complete main statusVar = do - resQ <- STM.newTQueueIO - threadsVar <- STM.newTVarIO Set.empty - let acceptLoopDo = acceptLoop acceptPolicyTrace resQ threadsVar statusVar acceptedConnectionLimit beginConnection applicationStart acceptException socket - -- The accept loop is killed when the main loop stops and the main - -- loop is killed if the accept loop stops. - mainDo = mainLoop errroPolicyTrace resQ threadsVar statusVar complete main - killChildren = do - children <- STM.atomically $ STM.readTVar threadsVar - forM_ (Set.toList children) Async.cancel - -- After both the main and accept loop have been killed, any remaining - -- spawned threads are cancelled. - (snd <$> Async.concurrently acceptLoopDo mainDo) `finally` killChildren diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs b/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs index 247ed78b9e2..fb7037b28a9 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs @@ -24,15 +24,8 @@ module Ouroboros.Network.Socket ConnectionTable , ConnectionTableRef (..) , ValencyCounter - , NetworkMutableState (..) , SomeResponderApplication (..) - , newNetworkMutableState - , newNetworkMutableStateSTM - , cleanNetworkMutableState - , AcceptedConnectionsLimit (..) , ConnectionId (..) - , withServerNode - , withServerNode' , ConnectToArgs (..) , connectToNode , connectToNodeWithMux @@ -47,17 +40,8 @@ module Ouroboros.Network.Socket , NetworkConnectTracers (..) , nullNetworkConnectTracers , debuggingNetworkConnectTracers - , NetworkServerTracers (..) - , nullNetworkServerTracers - , debuggingNetworkServerTracers - , AcceptConnectionsPolicyTrace (..) - -- * Helper function for creating servers - , fromSnocket - , beginConnection -- * Re-export of HandshakeCallbacks , HandshakeCallbacks (..) - -- * Re-export of PeerStates - , PeerStates -- * Re-export connection table functions , newConnectionTable , refConnection @@ -70,33 +54,24 @@ module Ouroboros.Network.Socket , readValencyCounter -- * Auxiliary functions , sockAddrFamily + , simpleMuxCallback ) where -import Control.Applicative (Alternative) -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Exception (SomeException (..)) -import Control.Monad.Class.MonadAsync --- TODO: remove this, it will not be needed when `orElse` PR will be merged. import Codec.CBOR.Read qualified as CBOR import Codec.CBOR.Term qualified as CBOR +import Control.Applicative (Alternative) +import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad (unless, when) +import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime.SI -import Control.Monad.Class.MonadTimer.SI -import Control.Monad.STM qualified as STM import Data.Bifunctor (first) import Data.ByteString.Lazy qualified as BL import Data.Foldable (traverse_) -import Data.Functor (void) import Data.Hashable import Data.Monoid.Synchronisation (FirstToFinish (..)) import Data.Typeable (Typeable) -import Data.Void import Data.Word (Word16) -import GHC.IO.Exception -#if !defined(mingw32_HOST_OS) -import Foreign.C.Error -#endif import Network.Socket (SockAddr, Socket, StructLinger (..)) import Network.Socket qualified as Socket @@ -110,7 +85,6 @@ import Network.TypedProtocol.Codec hiding (decode, encode) import Ouroboros.Network.Context import Ouroboros.Network.Driver.Limits -import Ouroboros.Network.ErrorPolicy import Ouroboros.Network.Handshake (HandshakeCallbacks (..)) import Ouroboros.Network.IOManager (IOManager) import Ouroboros.Network.Mux @@ -118,12 +92,8 @@ import Ouroboros.Network.Protocol.Handshake import Ouroboros.Network.Protocol.Handshake.Codec import Ouroboros.Network.Protocol.Handshake.Type import Ouroboros.Network.Server.ConnectionTable -import Ouroboros.Network.Server.Socket (AcceptConnectionsPolicyTrace (..), - AcceptedConnectionsLimit (..)) -import Ouroboros.Network.Server.Socket qualified as Server import Ouroboros.Network.Snocket (Snocket) import Ouroboros.Network.Snocket qualified as Snocket -import Ouroboros.Network.Subscription.PeerState -- | Tracer used by 'connectToNode' (and derivatives, like @@ -530,451 +500,3 @@ data SomeResponderApplication addr bytes m b where Mx.HasResponder muxMode ~ True => (OuroborosApplicationWithMinimalCtx muxMode addr bytes m a b) -> SomeResponderApplication addr bytes m b - --- | --- Accept or reject an incoming connection. Each record contains the new state --- after accepting / rejecting a connection. When accepting a connection one --- has to give a mux application which necessarily has the server side, and --- optionally has the client side. --- --- TODO: --- If the other side will not allow us to run the client side on the incoming --- connection, the whole connection will terminate. We might want to be more --- admissible in this scenario: leave the server thread running and let only --- the client thread to die. -data AcceptConnection st vNumber vData peerid m bytes where - - AcceptConnection - :: forall st vNumber vData peerid bytes m b. - !st - -> !(ConnectionId peerid) - -> Versions vNumber vData (SomeResponderApplication peerid bytes m b) - -> AcceptConnection st vNumber vData peerid m bytes - - RejectConnection - :: !st - -> !(ConnectionId peerid) - -> AcceptConnection st vNumber vData peerid m bytes - - --- | Accept or reject incoming connection based on the current state and --- address of the incoming connection. --- -beginConnection - :: forall vNumber vData addr st fd. - ( Ord vNumber - , Typeable vNumber - , Show vNumber - ) - => Mx.MakeBearer IO fd - -> Tracer IO (Mx.WithBearer (ConnectionId addr) Mx.Trace) - -> Tracer IO (Mx.WithBearer (ConnectionId addr) (TraceSendRecv (Handshake vNumber CBOR.Term))) - -> Codec (Handshake vNumber CBOR.Term) CBOR.DeserialiseFailure IO BL.ByteString - -> ProtocolTimeLimits (Handshake vNumber CBOR.Term) - -> VersionDataCodec CBOR.Term vNumber vData - -> HandshakeCallbacks vData - -> (Time -> addr -> st -> STM.STM (AcceptConnection st vNumber vData addr IO BL.ByteString)) - -- ^ either accept or reject a connection. - -> Server.BeginConnection addr fd st () -beginConnection makeBearer muxTracer handshakeTracer handshakeCodec handshakeTimeLimits versionDataCodec handshakeCallbacks fn t addr st = do - accept <- fn t addr st - case accept of - AcceptConnection st' connectionId versions -> pure $ Server.Accept st' $ \sd -> do - muxTracer' <- initDeltaQTracer' $ Mx.WithBearer connectionId `contramap` muxTracer - - traceWith muxTracer' $ Mx.TraceHandshakeStart - - handshakeBearer <- Mx.getBearer makeBearer sduHandshakeTimeout muxTracer' sd - app_e <- - runHandshakeServer - handshakeBearer - connectionId - HandshakeArguments { - haHandshakeTracer = handshakeTracer, - haHandshakeCodec = handshakeCodec, - haVersionDataCodec = versionDataCodec, - haAcceptVersion = acceptCb handshakeCallbacks, - haQueryVersion = queryCb handshakeCallbacks, - haTimeLimits = handshakeTimeLimits - } - versions - - case app_e of - Left (HandshakeProtocolLimit err) -> do - traceWith muxTracer' $ Mx.TraceHandshakeServerError err - throwIO err - - Left (HandshakeProtocolError err) -> do - traceWith muxTracer' $ Mx.TraceHandshakeServerError err - throwIO err - - Right (HandshakeNegotiationResult (SomeResponderApplication app) versionNumber agreedOptions) -> do - traceWith muxTracer' Mx.TraceHandshakeServerEnd - bearer <- Mx.getBearer makeBearer sduTimeout muxTracer' sd - mux <- Mx.new (toMiniProtocolInfos app) - withAsync (Mx.run muxTracer' mux bearer) $ \aid -> - void $ simpleMuxCallback connectionId versionNumber agreedOptions app mux aid - - Right (HandshakeQueryResult _vMap) -> do - traceWith muxTracer' Mx.TraceHandshakeServerEnd - -- Wait 20s for client to receive response, who should close the connection. - threadDelay handshake_QUERY_SHUTDOWN_DELAY - - RejectConnection st' _peerid -> pure $ Server.Reject st' - - -mkListeningSocket - :: Snocket IO fd addr - -> (fd -> addr -> IO ()) - -> addr - -> Snocket.AddressFamily addr - -> IO fd -mkListeningSocket sn configureSock addr family_ = do - sd <- Snocket.open sn family_ - configureSock sd addr - Snocket.bind sn sd addr - Snocket.listen sn sd - pure sd - --- | --- Make a server-compatible socket from a network socket. --- -fromSnocket - :: forall fd addr. Ord addr - => ConnectionTable IO addr - -> Snocket IO fd addr - -> fd -- ^ socket or handle - -> IO (Server.Socket addr fd) -fromSnocket tblVar sn sd = go <$> Snocket.accept sn sd - where - go :: Snocket.Accept IO fd addr -> Server.Socket addr fd - go (Snocket.Accept accept) = Server.Socket $ do - (result, next) <- accept - case result of - Snocket.Accepted sd' remoteAddr -> do - -- TOOD: we don't need to that on each accept - localAddr <- Snocket.getLocalAddr sn sd' - atomically $ addConnection tblVar remoteAddr localAddr ConnectionInbound Nothing - pure (remoteAddr, sd', close remoteAddr localAddr sd', go next) - Snocket.AcceptFailure err -> - -- the is no way to construct 'Server.Socket'; This will be removed in a later commit! - throwIO err - - close remoteAddr localAddr sd' = do - removeConnection tblVar remoteAddr localAddr ConnectionInbound - Snocket.close sn sd' - - --- | Tracers required by a server which handles inbound connections. --- -data NetworkServerTracers addr vNumber = NetworkServerTracers { - nstMuxTracer :: Tracer IO (Mx.WithBearer (ConnectionId addr) Mx.Trace), - -- ^ low level mux-network tracer, which logs mux sdu (send and received) - -- and other low level multiplexing events. - nstHandshakeTracer :: Tracer IO (Mx.WithBearer (ConnectionId addr) - (TraceSendRecv (Handshake vNumber CBOR.Term))), - -- ^ handshake protocol tracer; it is important for analysing version - -- negotation mismatches. - nstErrorPolicyTracer :: Tracer IO (WithAddr addr ErrorPolicyTrace), - -- ^ error policy tracer; must not be 'nullTracer', otherwise all the - -- exceptions which are not matched by any error policy will be caught - -- and not logged or rethrown. - nstAcceptPolicyTracer :: Tracer IO AcceptConnectionsPolicyTrace - -- ^ tracing rate limiting of accepting connections. - } - -nullNetworkServerTracers :: NetworkServerTracers addr vNumber -nullNetworkServerTracers = NetworkServerTracers { - nstMuxTracer = nullTracer, - nstHandshakeTracer = nullTracer, - nstErrorPolicyTracer = nullTracer, - nstAcceptPolicyTracer = nullTracer - } - -debuggingNetworkServerTracers :: (Show addr, Show vNumber) - => NetworkServerTracers addr vNumber -debuggingNetworkServerTracers = NetworkServerTracers { - nstMuxTracer = showTracing stdoutTracer, - nstHandshakeTracer = showTracing stdoutTracer, - nstErrorPolicyTracer = showTracing stdoutTracer, - nstAcceptPolicyTracer = showTracing stdoutTracer - } - - --- | Mutable state maintained by the network component. --- -data NetworkMutableState addr = NetworkMutableState { - nmsConnectionTable :: ConnectionTable IO addr, - -- ^ 'ConnectionTable' which maintains information about current upstream and - -- downstream connections. - nmsPeerStates :: StrictTVar IO (PeerStates IO addr) - -- ^ 'PeerStates' which maintains state of each downstream / upstream peer - -- that errored, misbehaved or was not interesting to us. - } - -newNetworkMutableStateSTM :: STM.STM (NetworkMutableState addr) -newNetworkMutableStateSTM = - NetworkMutableState <$> newConnectionTableSTM - <*> newPeerStatesVarSTM - -newNetworkMutableState :: IO (NetworkMutableState addr) -newNetworkMutableState = atomically newNetworkMutableStateSTM - --- | Clean 'PeerStates' within 'NetworkMutableState' every 200s --- -cleanNetworkMutableState :: NetworkMutableState addr - -> IO () -cleanNetworkMutableState NetworkMutableState {nmsPeerStates} = - cleanPeerStates 200 nmsPeerStates - --- | --- Thin wrapper around @'Server.run'@. --- -runServerThread - :: forall vNumber vData fd addr b. - ( Ord vNumber - , Typeable vNumber - , Show vNumber - , Ord addr - ) - => NetworkServerTracers addr vNumber - -> NetworkMutableState addr - -> Snocket IO fd addr - -> Mx.MakeBearer IO fd - -> fd - -> AcceptedConnectionsLimit - -> Codec (Handshake vNumber CBOR.Term) CBOR.DeserialiseFailure IO BL.ByteString - -> ProtocolTimeLimits (Handshake vNumber CBOR.Term) - -> VersionDataCodec CBOR.Term vNumber vData - -> HandshakeCallbacks vData - -> Versions vNumber vData (SomeResponderApplication addr BL.ByteString IO b) - -> ErrorPolicies - -> IO Void -runServerThread NetworkServerTracers { nstMuxTracer - , nstHandshakeTracer - , nstErrorPolicyTracer - , nstAcceptPolicyTracer - } - NetworkMutableState { nmsConnectionTable - , nmsPeerStates } - sn - makeBearer - sd - acceptedConnectionsLimit - handshakeCodec - handshakeTimeLimits - versionDataCodec - handshakeCallbacks - versions - errorPolicies = do - sockAddr <- Snocket.getLocalAddr sn sd - serverSocket <- fromSnocket nmsConnectionTable sn sd - Server.run - nstErrorPolicyTracer - nstAcceptPolicyTracer - serverSocket - acceptedConnectionsLimit - (acceptException sockAddr) - (beginConnection makeBearer nstMuxTracer nstHandshakeTracer handshakeCodec handshakeTimeLimits versionDataCodec handshakeCallbacks (acceptConnectionTx sockAddr)) - -- register producer when application starts, it will be unregistered - -- using 'CompleteConnection' - (\remoteAddr thread st -> pure $ registerProducer remoteAddr thread - st) - completeTx mainTx (toLazyTVar nmsPeerStates) - where - mainTx :: Server.Main (PeerStates IO addr) Void - mainTx (ThrowException e) = throwIO e - mainTx PeerStates{} = retry - - -- When a connection completes, we do nothing. State is (). - -- Crucially: we don't re-throw exceptions, because doing so would - -- bring down the server. - completeTx :: Server.CompleteConnection - addr - (PeerStates IO addr) - (WithAddr addr ErrorPolicyTrace) - () - completeTx result st = case result of - - Server.Result thread remoteAddr t (Left (SomeException e)) -> - fmap (unregisterProducer remoteAddr thread) - <$> completeApplicationTx errorPolicies (ApplicationError t remoteAddr e) st - - Server.Result thread remoteAddr t (Right r) -> - fmap (unregisterProducer remoteAddr thread) - <$> completeApplicationTx errorPolicies (ApplicationResult t remoteAddr r) st - - iseCONNABORTED :: IOError -> Bool -#if defined(mingw32_HOST_OS) - -- On Windows the network packet classifies all errors - -- as OtherError. This means that we're forced to match - -- on the error string. The text string comes from - -- the network package's winSockErr.c, and if it ever - -- changes we must update our text string too. - iseCONNABORTED (IOError _ _ _ "Software caused connection abort (WSAECONNABORTED)" _ _) = True - iseCONNABORTED _ = False -#else - iseCONNABORTED (IOError _ _ _ _ (Just cerrno) _) = eCONNABORTED == Errno cerrno -#if defined(darwin_HOST_OS) - -- There is a bug in accept for IPv6 sockets. Instead of returning -1 - -- and setting errno to ECONNABORTED an invalid (>= 0) file descriptor - -- is returned, with the client address left unchanged. The uninitialized - -- client address causes the network package to throw the user error below. - iseCONNABORTED (IOError _ UserError _ "Network.Socket.Types.peekSockAddr: address family '0' not supported." _ _) = True -#endif - iseCONNABORTED _ = False -#endif - - - acceptException :: addr -> IOException -> IO () - acceptException a e = do - traceWith (WithAddr a `contramap` nstErrorPolicyTracer) $ ErrorPolicyAcceptException e - - -- Try the determine if the connection was aborted by the remote end - -- before we could process the accept, or if it was a resource exaustion - -- problem. - -- NB. This piece of code is fragile and depends on specific - -- strings/mappings in the network and base libraries. - if iseCONNABORTED e then return () - else throwIO e - - acceptConnectionTx sockAddr t connAddr st = do - d <- beforeConnectTx t connAddr st - case d of - AllowConnection st' -> pure $ AcceptConnection st' (ConnectionId sockAddr connAddr) versions - OnlyAccept st' -> pure $ AcceptConnection st' (ConnectionId sockAddr connAddr) versions - DisallowConnection st' -> pure $ RejectConnection st' (ConnectionId sockAddr connAddr) - --- | Run a server application. It will listen on the given address for incoming --- connection, otherwise like withServerNode'. -withServerNode - :: forall vNumber vData t fd addr b. - ( Ord vNumber - , Typeable vNumber - , Show vNumber - , Ord addr - ) - => Snocket IO fd addr - -> Mx.MakeBearer IO fd - -> (fd -> addr -> IO ()) -- ^ callback to configure a socket - -> NetworkServerTracers addr vNumber - -> NetworkMutableState addr - -> AcceptedConnectionsLimit - -> addr - -> Codec (Handshake vNumber CBOR.Term) CBOR.DeserialiseFailure IO BL.ByteString - -> ProtocolTimeLimits (Handshake vNumber CBOR.Term) - -> VersionDataCodec CBOR.Term vNumber vData - -> HandshakeCallbacks vData - -> Versions vNumber vData (SomeResponderApplication addr BL.ByteString IO b) - -- ^ The mux application that will be run on each incoming connection from - -- a given address. Note that if @'MuxClientAndServerApplication'@ is - -- returned, the connection will run a full duplex set of mini-protocols. - -> ErrorPolicies - -> (addr -> Async IO Void -> IO t) - -- ^ callback which takes the @Async@ of the thread that is running the server. - -- Note: the server thread will terminate when the callback returns or - -- throws an exception. - -> IO t -withServerNode sn makeBearer - configureSock - tracers - networkState - acceptedConnectionsLimit - addr - handshakeCodec - handshakeTimeLimits - versionDataCodec - handshakeCallbacks - versions - errorPolicies - k = - bracket (mkListeningSocket sn configureSock addr (Snocket.addrFamily sn addr)) (Snocket.close sn) $ \sd -> do - withServerNode' - sn - makeBearer - tracers - networkState - acceptedConnectionsLimit - sd - handshakeCodec - handshakeTimeLimits - versionDataCodec - handshakeCallbacks - versions - errorPolicies - k - --- | --- Run a server application on the provided socket. The socket must be ready to accept connections. --- The server thread runs using @withAsync@ function, which means --- that it will terminate when the callback terminates or throws an exception. --- --- TODO: we should track connections in the state and refuse connections from --- peers we are already connected to. This is also the right place to ban --- connection from peers which misbehaved. --- --- The server will run handshake protocol on each incoming connection. We --- assume that each version negotiation message should fit into --- @'maxTransmissionUnit'@ (~5k bytes). --- --- Note: it will open a socket in the current thread and pass it to the spawned --- thread which runs the server. This makes it useful for testing, where we --- need to guarantee that a socket is open before we try to connect to it. -withServerNode' - :: forall vNumber vData t fd addr b. - ( Ord vNumber - , Typeable vNumber - , Show vNumber - , Ord addr - ) - => Snocket IO fd addr - -> Mx.MakeBearer IO fd - -> NetworkServerTracers addr vNumber - -> NetworkMutableState addr - -> AcceptedConnectionsLimit - -> fd - -- ^ a configured socket to be used be the server. The server will call - -- `bind` and `listen` methods but it will not set any socket or tcp options - -- on it. - -> Codec (Handshake vNumber CBOR.Term) CBOR.DeserialiseFailure IO BL.ByteString - -> ProtocolTimeLimits (Handshake vNumber CBOR.Term) - -> VersionDataCodec CBOR.Term vNumber vData - -> HandshakeCallbacks vData - -> Versions vNumber vData (SomeResponderApplication addr BL.ByteString IO b) - -- ^ The mux application that will be run on each incoming connection from - -- a given address. Note that if @'MuxClientAndServerApplication'@ is - -- returned, the connection will run a full duplex set of mini-protocols. - -> ErrorPolicies - -> (addr -> Async IO Void -> IO t) - -- ^ callback which takes the @Async@ of the thread that is running the server. - -- Note: the server thread will terminate when the callback returns or - -- throws an exception. - -> IO t -withServerNode' sn makeBearer - tracers - networkState - acceptedConnectionsLimit - sd - handshakeCodec - handshakeTimeLimits - versionDataCodec - handshakeCallbacks - versions - errorPolicies - k = do - addr' <- Snocket.getLocalAddr sn sd - withAsync - (runServerThread - tracers - networkState - sn - makeBearer - sd - acceptedConnectionsLimit - handshakeCodec - handshakeTimeLimits - versionDataCodec - handshakeCallbacks - versions - errorPolicies) - (k addr') diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Subscription.hs b/ouroboros-network-framework/src/Ouroboros/Network/Subscription.hs deleted file mode 100644 index 0e8838fcd78..00000000000 --- a/ouroboros-network-framework/src/Ouroboros/Network/Subscription.hs +++ /dev/null @@ -1,28 +0,0 @@ --- | Public interface of 'Ouroboros.Network.Subscription' workers. --- -module Ouroboros.Network.Subscription - ( -- * IP Subscription Worker - ipSubscriptionWorker - , IPSubscriptionTarget (..) - -- * DNS Subscription Worker - , dnsSubscriptionWorker - , DnsSubscriptionTarget (..) - , ConnectResult (..) - -- * Constants - , defaultConnectionAttemptDelay - , minConnectionAttemptDelay - , maxConnectionAttemptDelay - , ipRetryDelay - , resolutionDelay - -- * Errors - , SubscriberError (..) - -- * Tracing - , SubscriptionTrace (..) - , WithIPList (..) - , DnsTrace (..) - , WithDomainName (..) - ) where - -import Ouroboros.Network.Subscription.Dns -import Ouroboros.Network.Subscription.Ip -import Ouroboros.Network.Subscription.Worker diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Client.hs b/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Client.hs deleted file mode 100644 index cb28902c1a9..00000000000 --- a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Client.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} - --- Subscription worker for client applications connecting with 'LocalSnocket' --- which is using either unix sockets or Windows' named pipes. --- -module Ouroboros.Network.Subscription.Client - ( ClientSubscriptionParams (..) - , clientSubscriptionWorker - ) where - -import Control.Monad.Class.MonadTime.SI -import Control.Tracer - -import Data.Functor.Identity (Identity (..)) -import Data.Void (Void) - -import Ouroboros.Network.ErrorPolicy (ErrorPolicies, ErrorPolicyTrace, WithAddr, - completeApplicationTx) -import Ouroboros.Network.Snocket (LocalAddress, LocalSnocket, LocalSocket) -import Ouroboros.Network.Socket (NetworkMutableState (..)) -import Ouroboros.Network.Subscription.Ip (mainTx, socketStateChangeTx) -import Ouroboros.Network.Subscription.Subscriber -import Ouroboros.Network.Subscription.Worker - - -data ClientSubscriptionParams a = ClientSubscriptionParams - { cspAddress :: !LocalAddress - -- ^ unix socket or named pipe address - , cspConnectionAttemptDelay :: !(Maybe DiffTime) - -- ^ delay between connection attempts - , cspErrorPolicies :: !ErrorPolicies - -- ^ error policies for subscription worker - } - --- | Client subscription worker keeps subscribing to the 'LocalAddress' using --- either unix socket or named pipe. --- -clientSubscriptionWorker - :: LocalSnocket - -> Tracer IO (SubscriptionTrace LocalAddress) - -> Tracer IO (WithAddr LocalAddress ErrorPolicyTrace) - -> NetworkMutableState LocalAddress - -> ClientSubscriptionParams a - -> (LocalSocket -> IO a) - -> IO Void -clientSubscriptionWorker snocket - tracer - errorPolicyTracer - NetworkMutableState { nmsConnectionTable, nmsPeerStates } - ClientSubscriptionParams { cspAddress - , cspConnectionAttemptDelay - , cspErrorPolicies - } - k = - worker tracer - errorPolicyTracer - nmsConnectionTable - nmsPeerStates - snocket - mempty - WorkerCallbacks - { wcSocketStateChangeTx = socketStateChangeTx - , wcCompleteApplicationTx = completeApplicationTx cspErrorPolicies - , wcMainTx = mainTx - } - workerParams - k - where - workerParams :: WorkerParams IO Identity LocalAddress - workerParams = WorkerParams { - wpLocalAddresses = Identity cspAddress, - wpSelectAddress = \_ (Identity addr) -> Just addr, - wpConnectionAttemptDelay = const cspConnectionAttemptDelay, - wpSubscriptionTarget = pure (listSubscriptionTarget [cspAddress]), - wpValency = 1 - } diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Dns.hs b/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Dns.hs deleted file mode 100644 index 6a4c4f23935..00000000000 --- a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Dns.hs +++ /dev/null @@ -1,324 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - -{- Partial implementation of RFC8305, https://tools.ietf.org/html/rfc8305 . - - Prioritization of destination addresses doesn't implement longest prefix matching - - and doesn't take address scope etc. into account. - -} - -module Ouroboros.Network.Subscription.Dns - ( DnsSubscriptionTarget (..) - , Resolver (..) - , DnsSubscriptionParams - , dnsSubscriptionWorker' - , dnsSubscriptionWorker - , dnsResolve - , resolutionDelay - -- * Traces - , SubscriptionTrace (..) - , DnsTrace (..) - , ErrorPolicyTrace (..) - , WithDomainName (..) - , WithAddr (..) - ) where - -import Control.Concurrent.Class.MonadSTM qualified as Lazy -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime.SI -import Control.Monad.Class.MonadTimer.SI -import Control.Tracer -import Data.IP qualified as IP -import Data.Maybe (isJust) -import Data.Void (Void) -import Network.DNS qualified as DNS -import Network.Socket qualified as Socket -import Text.Printf - -import Ouroboros.Network.ErrorPolicy -import Ouroboros.Network.Snocket (Snocket) -import Ouroboros.Network.Socket -import Ouroboros.Network.Subscription.Ip -import Ouroboros.Network.Subscription.Subscriber -import Ouroboros.Network.Subscription.Worker - - --- | Time to wait for an AAAA response after receiving an A response. -resolutionDelay :: DiffTime -resolutionDelay = 0.05 -- 50ms delay - - -data DnsSubscriptionTarget = DnsSubscriptionTarget { - dstDomain :: !DNS.Domain - , dstPort :: !Socket.PortNumber - , dstValency :: !Int - } deriving (Eq, Show) - - -data Resolver m = Resolver { - lookupA :: DNS.Domain -> m (Either DNS.DNSError [Socket.SockAddr]) - , lookupAAAA :: DNS.Domain -> m (Either DNS.DNSError [Socket.SockAddr]) - } - -withResolver :: Socket.PortNumber -> DNS.ResolvSeed -> (Resolver IO -> IO a) -> IO a -withResolver port rs k = do - DNS.withResolver rs $ \dnsResolver -> - k (Resolver - (ipv4ToSockAddr dnsResolver) - (ipv6ToSockAddr dnsResolver)) - where - ipv4ToSockAddr dnsResolver d = do - r <- DNS.lookupA dnsResolver d - case r of - (Right ips) -> return $ Right $ map (Socket.SockAddrInet port . - IP.toHostAddress) ips - (Left e) -> return $ Left e - - ipv6ToSockAddr dnsResolver d = do - r <- DNS.lookupAAAA dnsResolver d - case r of - (Right ips) -> return $ Right $ map (\ip -> Socket.SockAddrInet6 port 0 (IP.toHostAddress6 ip) 0) ips - (Left e) -> return $ Left e - - -dnsResolve :: forall a m s. - ( MonadAsync m - , MonadCatch m - , MonadTimer m - ) - => Tracer m DnsTrace - -> m a - -> (a -> (Resolver m -> m (SubscriptionTarget m Socket.SockAddr)) -> m (SubscriptionTarget m Socket.SockAddr)) - -> StrictTVar m s - -> BeforeConnect m s Socket.SockAddr - -> DnsSubscriptionTarget - -> m (SubscriptionTarget m Socket.SockAddr) -dnsResolve tracer getSeed withResolverFn peerStatesVar beforeConnect (DnsSubscriptionTarget domain _ _) = do - rs_e <- (Right <$> getSeed) `catches` - [ Handler (\ (e :: DNS.DNSError) -> - return (Left $ toException e) :: m (Either SomeException a)) - -- On windows getSeed fails with BadConfiguration if the network is down. - , Handler (\ (e :: IOError) -> - return (Left $ toException e) :: m (Either SomeException a)) - -- On OSX getSeed can fail with IOError if all network devices are down. - ] - case rs_e of - Left e -> do - traceWith tracer $ DnsTraceLookupException e - return $ listSubscriptionTarget [] - - Right rs -> do - withResolverFn rs $ \resolver -> do - -- Though the DNS lib does have its own timeouts, these do not work - -- on Windows reliably so as a workaround we add an extra layer - -- of timeout on the outside. - -- TODO: Fix upstream dns lib. - -- On windows the aid_ipv6 and aid_ipv4 threads are leaked incase - -- of an exception in the main thread. - res <- timeout 20 $ do - aid_ipv6 <- async $ resolveAAAA resolver - aid_ipv4 <- async $ resolveA resolver aid_ipv6 - rd_e <- waitEitherCatch aid_ipv6 aid_ipv4 - case rd_e of - Left r -> do - traceWith tracer DnsTraceLookupIPv6First - handleThreadResult r $ threadTargetCycle aid_ipv4 - Right r -> do - traceWith tracer DnsTraceLookupIPv4First - handleThreadResult r $ threadTargetCycle aid_ipv6 - case res of - Nothing -> do - -- TODO: the thread timedout, we should trace it - return (SubscriptionTarget $ pure Nothing) - Just st -> - return (SubscriptionTarget $ pure st) - where - -- Creates a subscription target from an optional first socket and a tail - targetCons - :: Socket.SockAddr - -> m (Maybe (Socket.SockAddr, SubscriptionTarget m Socket.SockAddr)) - -> m (Maybe (Socket.SockAddr, SubscriptionTarget m Socket.SockAddr)) - targetCons addr next = do - b <- runBeforeConnect peerStatesVar beforeConnect addr - if b - then return $ Just (addr, SubscriptionTarget next) - else next - - -- Takes the result of a thread, returning an optional first socket in the subscription target result, - -- then calls the given function to get the tail - handleThreadResult - :: Either SomeException [Socket.SockAddr] - -> ([Socket.SockAddr] -> m (Maybe (Socket.SockAddr, SubscriptionTarget m Socket.SockAddr))) - -> m (Maybe (Socket.SockAddr, SubscriptionTarget m Socket.SockAddr)) - handleThreadResult (Left e) cont = do - traceWith tracer $ DnsTraceLookupException e - cont [] - handleThreadResult (Right []) cont = cont [] - handleThreadResult (Right (addr:addrs)) cont = targetCons addr $ cont addrs - - -- Called when a thread is still running, and the other finished already - -- Cycles between trying to get a result from the running thread, and the results of the finished thread - -- If results of the finished thread are exhausted, wait until the running thread completes - threadTargetCycle - :: Async m [Socket.SockAddr] - -> [Socket.SockAddr] - -> m (Maybe (Socket.SockAddr, SubscriptionTarget m Socket.SockAddr)) - threadTargetCycle asyn [] = do - result <- waitCatch asyn - handleThreadResult result $ targetCycle [] - threadTargetCycle asyn a@(addr : addrs) = do - result <- poll asyn - case result of - -- The running thread finished, handle the result, then cycle over all results - Just r -> handleThreadResult r $ targetCycle a - -- The running thread is still going, emit an address of the finished thread, then check again - Nothing -> targetCons addr $ threadTargetCycle asyn addrs - - -- Called when both threads exited and we know the results of both. - -- Returns a subscription target that cycles between the results until both results are exhausted - targetCycle - :: [Socket.SockAddr] - -> [Socket.SockAddr] - -> m (Maybe (Socket.SockAddr, SubscriptionTarget m Socket.SockAddr)) - targetCycle as bs = go (as `interleave` bs) - where - go [] = return Nothing - go (x : xs) = targetCons x (go xs) - - interleave [] ys = ys - interleave (x : xs) ys = x : interleave ys xs - - resolveAAAA :: Resolver m - -> m [Socket.SockAddr] - resolveAAAA resolver = do - r_e <- lookupAAAA resolver domain - case r_e of - Left e -> do - traceWith tracer $ DnsTraceLookupAAAAError e - return [] - Right r -> do - traceWith tracer $ DnsTraceLookupAAAAResult r - - -- XXX Addresses should be sorted here based on DeltaQueue. - return r - - resolveA :: Resolver m - -> Async m [Socket.SockAddr] - -> m [Socket.SockAddr] - resolveA resolver aid_ipv6 = do - r_e <- lookupA resolver domain - case r_e of - Left e -> do - traceWith tracer $ DnsTraceLookupAError e - return [] - Right r -> do - traceWith tracer $ DnsTraceLookupAResult r - - {- From RFC8305. - - If a positive A response is received first due to reordering, the client - - SHOULD wait a short time for the AAAA response to ensure that preference is - - given to IPv6. - -} - timeoutVar <- registerDelay resolutionDelay - atomically $ do - timedOut <- Lazy.readTVar timeoutVar - ipv6Done <- pollSTM aid_ipv6 - check (timedOut || isJust ipv6Done) - - -- XXX Addresses should be sorted here based on DeltaQueue. - return r - - -dnsSubscriptionWorker' - :: Snocket IO Socket.Socket Socket.SockAddr - -> Tracer IO (WithDomainName (SubscriptionTrace Socket.SockAddr)) - -> Tracer IO (WithDomainName DnsTrace) - -> Tracer IO (WithAddr Socket.SockAddr ErrorPolicyTrace) - -> NetworkMutableState Socket.SockAddr - -> IO b - -> (b -> (Resolver IO -> IO (SubscriptionTarget IO Socket.SockAddr)) - -> IO (SubscriptionTarget IO Socket.SockAddr)) - -> DnsSubscriptionParams a - -> Main IO (PeerStates IO Socket.SockAddr) x - -> (Socket.Socket -> IO a) - -> IO x -dnsSubscriptionWorker' snocket subTracer dnsTracer errorPolicyTracer - networkState@NetworkMutableState { nmsPeerStates } - setupResolver resolver - SubscriptionParams { spLocalAddresses - , spConnectionAttemptDelay - , spSubscriptionTarget = dst - , spErrorPolicies - } - main k = - subscriptionWorker snocket - (WithDomainName (dstDomain dst) `contramap` subTracer) - errorPolicyTracer - networkState - WorkerParams { wpLocalAddresses = spLocalAddresses - , wpConnectionAttemptDelay = spConnectionAttemptDelay - , wpSubscriptionTarget = - dnsResolve - (WithDomainName (dstDomain dst) `contramap` dnsTracer) - setupResolver resolver nmsPeerStates beforeConnectTx dst - , wpValency = dstValency dst - , wpSelectAddress = selectSockAddr - } - spErrorPolicies - main - k - - -type DnsSubscriptionParams a = SubscriptionParams a DnsSubscriptionTarget - -dnsSubscriptionWorker - :: Snocket IO Socket.Socket Socket.SockAddr - -> Tracer IO (WithDomainName (SubscriptionTrace Socket.SockAddr)) - -> Tracer IO (WithDomainName DnsTrace) - -> Tracer IO (WithAddr Socket.SockAddr ErrorPolicyTrace) - -> NetworkMutableState Socket.SockAddr - -> DnsSubscriptionParams a - -> (Socket.Socket -> IO a) - -> IO Void -dnsSubscriptionWorker snocket subTracer dnsTracer errTrace networkState - params@SubscriptionParams { spSubscriptionTarget } k = - dnsSubscriptionWorker' - snocket - subTracer dnsTracer errTrace - networkState - (DNS.makeResolvSeed DNS.defaultResolvConf) - (withResolver (dstPort spSubscriptionTarget)) - params - mainTx - k - -data WithDomainName a = WithDomainName { - wdnDomain :: DNS.Domain - , wdnEvent :: a - } - -instance Show a => Show (WithDomainName a) where - show WithDomainName {wdnDomain, wdnEvent} = printf "Domain: %s %s" (show wdnDomain) (show wdnEvent) - -data DnsTrace = - DnsTraceLookupException SomeException - | DnsTraceLookupAError DNS.DNSError - | DnsTraceLookupAAAAError DNS.DNSError - | DnsTraceLookupIPv6First - | DnsTraceLookupIPv4First - | DnsTraceLookupAResult [Socket.SockAddr] - | DnsTraceLookupAAAAResult [Socket.SockAddr] - -instance Show DnsTrace where - show (DnsTraceLookupException e) = "lookup exception " ++ show e - show (DnsTraceLookupAError e) = "A lookup failed with " ++ show e - show (DnsTraceLookupAAAAError e) = "AAAA lookup failed with " ++ show e - show DnsTraceLookupIPv4First = "Returning IPv4 address first" - show DnsTraceLookupIPv6First = "Returning IPv6 address first" - show (DnsTraceLookupAResult as) = "Lookup A result: " ++ show as - show (DnsTraceLookupAAAAResult as) = "Lookup AAAAA result: " ++ show as diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Ip.hs b/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Ip.hs deleted file mode 100644 index 3f1755c081d..00000000000 --- a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Ip.hs +++ /dev/null @@ -1,233 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | IP subscription worker implentation. -module Ouroboros.Network.Subscription.Ip - ( SubscriptionParams (..) - , IPSubscriptionParams - , ipSubscriptionWorker - , subscriptionWorker - , IPSubscriptionTarget (..) - , ipSubscriptionTarget - -- * Traces - , SubscriptionTrace (..) - , ErrorPolicyTrace (..) - , WithIPList (..) - -- * 'PeerState' STM transactions - , BeforeConnect - , runBeforeConnect - , beforeConnectTx - , completeApplicationTx - , socketStateChangeTx - , mainTx - -- * Utilitity functions - , selectSockAddr - ) where - - -{- The parallel connection attemps implemented in this module is inspired by - - RFC8305, https://tools.ietf.org/html/rfc8305 . - -} - -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime.SI -import Control.Tracer -import Data.Void (Void) -import Network.Socket qualified as Socket -import Text.Printf - -import Ouroboros.Network.ErrorPolicy -import Ouroboros.Network.Snocket (Snocket) -import Ouroboros.Network.Socket -import Ouroboros.Network.Subscription.PeerState -import Ouroboros.Network.Subscription.Subscriber -import Ouroboros.Network.Subscription.Worker - - -data IPSubscriptionTarget = IPSubscriptionTarget { - -- | List of destinations to possibly connect to - ispIps :: ![Socket.SockAddr] - -- | Number of parallel connections to keep actice. - , ispValency :: !Int - } deriving (Eq, Show) - - --- | 'ipSubscriptionWorker' and 'dnsSubscriptionWorker' parameters --- -data SubscriptionParams a target = SubscriptionParams - { spLocalAddresses :: LocalAddresses Socket.SockAddr - , spConnectionAttemptDelay :: Socket.SockAddr -> Maybe DiffTime - -- ^ should return expected delay for the given address - , spErrorPolicies :: ErrorPolicies - , spSubscriptionTarget :: target - } - -type IPSubscriptionParams a = SubscriptionParams a IPSubscriptionTarget - --- | Spawns a subscription worker which will attempt to keep the specified --- number of connections (Valency) active towards the list of IP addresses --- given in IPSubscriptionTarget. --- -ipSubscriptionWorker - :: forall a. - Snocket IO Socket.Socket Socket.SockAddr - -> Tracer IO (WithIPList (SubscriptionTrace Socket.SockAddr)) - -> Tracer IO (WithAddr Socket.SockAddr ErrorPolicyTrace) - -> NetworkMutableState Socket.SockAddr - -> IPSubscriptionParams a - -> (Socket.Socket -> IO a) - -> IO Void -ipSubscriptionWorker snocket subscriptionTracer errorPolicyTracer - networkState@NetworkMutableState { nmsPeerStates } - SubscriptionParams { spLocalAddresses - , spConnectionAttemptDelay - , spSubscriptionTarget - , spErrorPolicies - } - k = - subscriptionWorker snocket - subscriptionTracer' - errorPolicyTracer - networkState - workerParams - spErrorPolicies - mainTx - k - where - workerParams = WorkerParams { - wpLocalAddresses = spLocalAddresses, - wpConnectionAttemptDelay = spConnectionAttemptDelay, - wpSubscriptionTarget = - pure $ ipSubscriptionTarget subscriptionTracer' nmsPeerStates - (ispIps spSubscriptionTarget), - wpValency = ispValency spSubscriptionTarget, - wpSelectAddress = selectSockAddr - } - - subscriptionTracer' = (WithIPList spLocalAddresses (ispIps spSubscriptionTarget) - `contramap` subscriptionTracer) - -selectSockAddr :: Socket.SockAddr - -> LocalAddresses Socket.SockAddr - -> Maybe Socket.SockAddr -selectSockAddr Socket.SockAddrInet{} (LocalAddresses (Just localAddr) _ _ ) = Just localAddr -selectSockAddr Socket.SockAddrInet6{} (LocalAddresses _ (Just localAddr) _ ) = Just localAddr -selectSockAddr Socket.SockAddrUnix{} (LocalAddresses _ _ (Just localAddr) ) = Just localAddr -selectSockAddr _ _ = Nothing - - -ipSubscriptionTarget :: forall m addr. - ( MonadMonotonicTime m - , MonadSTM m - , Ord addr - ) - => Tracer m (SubscriptionTrace addr) - -> StrictTVar m (PeerStates m addr) - -> [addr] - -> SubscriptionTarget m addr -ipSubscriptionTarget tr peerStatesVar ips = go ips - where - go :: [addr] - -> SubscriptionTarget m addr - go [] = SubscriptionTarget $ pure Nothing - go (a : as) = SubscriptionTarget $ do - b <- runBeforeConnect peerStatesVar beforeConnectTx a - if b - then do - traceWith tr $ SubscriptionTraceTryConnectToPeer a - pure $ Just (a, go as) - else do - traceWith tr $ SubscriptionTraceSkippingPeer a - getSubscriptionTarget $ go as - - --- when creating a new socket: register consumer thread --- when tearing down a socket: unregister consumer thread -socketStateChangeTx - :: Ord addr - => SocketStateChange IO - (PeerStates IO addr) - addr - -socketStateChangeTx (CreatedSocket addr thread) ps = - pure (registerConsumer addr thread ps) - -socketStateChangeTx ClosedSocket{} ps@ThrowException{} = - pure ps - -socketStateChangeTx (ClosedSocket addr thread) ps = - pure $ unregisterConsumer addr thread ps - - --- | Main callback. It throws an exception when the state becomes --- 'ThrowException'. This exception is thrown from the main thread. --- -mainTx :: ( MonadThrow (STM m) - , MonadSTM m - ) - => Main m (PeerStates m addr) Void -mainTx (ThrowException e) = throwIO e -mainTx PeerStates{} = retry - - --- | Like 'worker' but in 'IO'; It provides address selection function, --- 'SocketStateChange' and 'CompleteApplication' callbacks. The 'Main' --- callback is left as it's useful for testing purposes. --- -subscriptionWorker - :: Snocket IO Socket.Socket Socket.SockAddr - -> Tracer IO (SubscriptionTrace Socket.SockAddr) - -> Tracer IO (WithAddr Socket.SockAddr ErrorPolicyTrace) - -> NetworkMutableState Socket.SockAddr - -> WorkerParams IO LocalAddresses Socket.SockAddr - -> ErrorPolicies - -> Main IO (PeerStates IO Socket.SockAddr) x - -- ^ main callback - -> (Socket.Socket -> IO a) - -- ^ application to run on each connection - -> IO x -subscriptionWorker snocket - tracer - errorPolicyTracer - NetworkMutableState { nmsConnectionTable, nmsPeerStates } - workerParams - errorPolicies - main k = - worker tracer - errorPolicyTracer - nmsConnectionTable - nmsPeerStates - snocket - ((. Just) <$> configureSocket) - WorkerCallbacks - { wcSocketStateChangeTx = socketStateChangeTx - , wcCompleteApplicationTx = completeApplicationTx errorPolicies - , wcMainTx = main - } - workerParams - k - -data WithIPList a = WithIPList { - wilSrc :: (LocalAddresses Socket.SockAddr) - , wilDsts :: [Socket.SockAddr] - , wilEvent :: a - } - -instance (Show a) => Show (WithIPList a) where - show (WithIPList (LocalAddresses Nothing (Just ipv6) Nothing) wilDsts wilEvent) = - printf "IPs: %s %s %s" (show ipv6) (show wilDsts) (show wilEvent) - show (WithIPList (LocalAddresses (Just ipv4) Nothing Nothing) wilDsts wilEvent) = - printf "IPs: %s %s %s" (show ipv4) (show wilDsts) (show wilEvent) - show (WithIPList (LocalAddresses Nothing Nothing (Just unix)) wilDsts wilEvent) = - printf "IPs: %s %s %s" (show unix) (show wilDsts) (show wilEvent) - show (WithIPList (LocalAddresses (Just ipv4) (Just ipv6) Nothing) wilDsts wilEvent) = - printf "IPs: %s %s %s %s" (show ipv4) (show ipv6) - (show wilDsts) (show wilEvent) - show WithIPList {wilSrc, wilDsts, wilEvent} = - printf "IPs: %s %s %s" (show wilSrc) (show wilDsts) (show wilEvent) - diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/PeerState.hs b/ouroboros-network-framework/src/Ouroboros/Network/Subscription/PeerState.hs deleted file mode 100644 index 93cf0fe8f73..00000000000 --- a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/PeerState.hs +++ /dev/null @@ -1,599 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | This module contains peer state management and error policies. --- -module Ouroboros.Network.Subscription.PeerState - ( SuspendDecision (..) - , suspend - -- * PeerStates and its operations - , PeerState (..) - , threadsToCancel - , PeerStates (..) - , newPeerStatesVar - , newPeerStatesVarSTM - , cleanPeerStates - , runSuspendDecision - , registerConsumer - , unregisterConsumer - , registerProducer - , unregisterProducer - , BeforeConnect - , ConnectDecision (..) - , runBeforeConnect - , beforeConnectTx - -- * Re-exports - , DiffTime - -- * Auxiliary functions - , alterAndLookup - ) where - -import Control.Exception (Exception, SomeException (..), assert) -import Control.Monad.State -import Data.Map qualified as Map -import Data.Map.Strict (Map) -import Data.Set (Set) -import Data.Set qualified as Set -import Data.Typeable (eqT, (:~:) (..)) - -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadTime.SI -import Control.Monad.Class.MonadTimer.SI - -import Data.Semigroup.Action - --- | Semigroup of commands which acts on 'PeerState'. The @t@ variable might --- be initiated to 'DiffTime' or @Time m@. --- --- This semigroup allows to either suspend both consumer and producer or just --- the consumer part. --- -data SuspendDecision t - = SuspendPeer !t !t - -- ^ peer is suspend; The first @t@ is the time until which a local - -- producer is suspended, the second one is the time until which a local - -- consumer is suspended. - | SuspendConsumer !t - -- ^ suspend local consumer \/ initiator side until @t@ (this mean we are - -- not allowing to communicate with the producer \/ responder of a remote - -- peer). - | Throw - -- ^ throw an error from the main thread. - deriving (Eq, Ord, Show, Functor) - -consumerSuspendedUntil :: SuspendDecision t -> Maybe t -consumerSuspendedUntil (SuspendPeer _ consT) = Just consT -consumerSuspendedUntil (SuspendConsumer consT) = Just consT -consumerSuspendedUntil Throw = Nothing - -producerSuspendedUntil :: SuspendDecision t -> Maybe t -producerSuspendedUntil (SuspendPeer prodT _) = Just prodT -producerSuspendedUntil (SuspendConsumer _) = Nothing -producerSuspendedUntil Throw = Nothing - --- | The semigroup instance. Note that composing 'SuspendPeer' with --- 'SuspendConsumer' gives 'SuspendPeer'. 'SuspendPeer' and 'SuspendConsumer' --- form a sub-semigroup. --- -instance Ord t => Semigroup (SuspendDecision t) where - Throw <> _ = Throw - _ <> Throw = Throw - SuspendPeer prodT consT <> SuspendPeer prodT' consT' - = SuspendPeer (prodT `max` prodT') (consT `max` consT') - SuspendConsumer consT <> SuspendPeer prodT consT' - = SuspendPeer prodT (consT `max` consT') - SuspendPeer prodT consT <> SuspendConsumer consT' - = SuspendPeer prodT (consT `max` consT') - SuspendConsumer consT <> SuspendConsumer consT' - = SuspendConsumer (consT `max` consT') - - -data PeerState m - = HotPeer !(Set (Async m ())) !(Set (Async m ())) - -- ^ active peer with its producers and consumer threads - | SuspendedConsumer !(Set (Async m ())) !Time - -- ^ suspended consumer: with producer threads and time until the consumer is - -- suspended - | SuspendedPeer !Time !Time - -- ^ suspended peer: producer & consumer suspend time - | ColdPeer - -- ^ peer with no opened connections in either direction - -instance ( MonadAsync m - ) => Show (PeerState m) where - show (HotPeer producers consumers) - = "HotPeer" - ++ " " - ++ show (Set.map asyncThreadId producers) - ++ " " - ++ show (Set.map asyncThreadId consumers) - show (SuspendedConsumer producers consT) - = "SuspendedConsumer" - ++ " " - ++ show (Set.map asyncThreadId producers) - ++ " " - ++ show consT - show (SuspendedPeer prodT consT) - = "SuspendedPeer" - ++ " " - ++ show prodT - ++ " " - ++ show consT - show ColdPeer = "ColdPeer" - -deriving instance Eq (Async m ()) => Eq (PeerState m) - -deriving instance Ord (Async m ()) => Ord (PeerState m) - --- | Action of 'SuspendDecision' on @Maybe 'PeerState'@. We use this action --- together with 'Map.alter' function. --- --- Note: 'SuspendDecision' does not act on 'PeerState', only the sub-semigroup --- generated by 'SuspendConsumer' and 'SuspendPeer' does. --- --- -instance SAct (SuspendDecision Time) (Maybe (PeerState m)) where - - -- this means we will remove the entry from the state map; this is fine - -- since we are about to throw an exception to kill a node. - _ <| Throw = Nothing - Nothing <| _ = Nothing - - -- this might apply when a connection to a 'ColdPeer' thrown an - -- exception. - (Just ColdPeer) <| (SuspendConsumer consT) - = Just $ SuspendedConsumer Set.empty consT - (Just ColdPeer) <| (SuspendPeer prodT consT) - = Just (SuspendedPeer prodT consT) - - (Just (HotPeer producers _consumers)) <| (SuspendConsumer consT) - = Just $ SuspendedConsumer producers consT - (Just (HotPeer _prodcuers _consumers)) <| (SuspendPeer prodT consT) - = Just $ SuspendedPeer prodT consT - - (Just (SuspendedConsumer producers consT)) <| (SuspendConsumer consT') - = Just $ SuspendedConsumer producers (consT `max` consT') - (Just (SuspendedConsumer _producers consT)) <| (SuspendPeer prodT consT') - = Just $ SuspendedPeer prodT (consT `max` consT') - - (Just (SuspendedPeer prodT consT)) <| cmd - = case producerSuspendedUntil cmd of - Nothing -> - Just $ SuspendedPeer - prodT - (maybe consT (consT `max`) $ consumerSuspendedUntil cmd) - Just prodT' -> - Just $ SuspendedPeer - (prodT `max` prodT') - (maybe consT (consT `max`) $ consumerSuspendedUntil cmd) - --- | Threads which needs to be cancelled when updating the 'PeerState' with --- 'SuspendDecision'. --- -threadsToCancel :: Ord (Async m ()) - => PeerState m - -> SuspendDecision diffTime - -> Set (Async m ()) -threadsToCancel _ Throw - = Set.empty -threadsToCancel ColdPeer _ - = Set.empty -threadsToCancel (HotPeer _producers consumers) SuspendConsumer{} - = consumers -threadsToCancel (HotPeer consumers producers) SuspendPeer{} - = consumers <> producers -threadsToCancel SuspendedConsumer{} SuspendConsumer{} - = Set.empty -threadsToCancel (SuspendedConsumer producers _consT) SuspendPeer{} - = producers -threadsToCancel SuspendedPeer{} _cmd - = Set.empty - - --- | Action of 'SuspendDecision' on @Maybe 'PeerState'@. Action laws are only --- satisfied for the submonoid form by 'SuspendPeer' and 'SuspendConsumer'. --- -suspend :: Ord (Async m ()) - => Maybe (PeerState m) - -> SuspendDecision Time - -> ( Set (Async m ()) - , Maybe (PeerState m) - ) -suspend mbps cmd = ( maybe Set.empty (`threadsToCancel` cmd) mbps - , mbps <| cmd - ) - - --- | Map from addresses to 'PeerState's; it will be be shared in a 'StrictTVar'. --- --- Abstracting @t@ is useful for tests, the @IO@ version will use @Time IO@. --- -data PeerStates m addr where - -- | Map of peer states - PeerStates :: !(Map addr (PeerState m)) - -> PeerStates m addr - - -- | Or an exception to throw - ThrowException :: Exception e - => e - -> PeerStates m addr - -instance Show addr - => Show (PeerStates IO addr) where - show (PeerStates ps) = "PeerStates " ++ show ps - show (ThrowException e) = "ThrowException " ++ show e - --- TODO: move to Test.PeerStates as eqPeerStates -instance Eq addr - => Eq (PeerStates IO addr) where - ThrowException (_ :: e) == ThrowException (_ :: e') = - case eqT :: Maybe (e :~: e') of - Nothing -> False - Just Refl -> True - PeerStates ps == PeerStates ps' = ps == ps' - _ == _ = False - - -newPeerStatesVarSTM :: MonadSTM m => STM m (StrictTVar m (PeerStates m addr)) -newPeerStatesVarSTM = newTVar (PeerStates Map.empty) - -newPeerStatesVar :: MonadSTM m => m (StrictTVar m (PeerStates m addr)) -newPeerStatesVar = atomically newPeerStatesVarSTM - - --- | Periodically clean 'PeerState'. It will stop when 'PeerState' becomes --- 'ThrowException'. --- -cleanPeerStates :: ( MonadDelay m - , MonadTimer m - ) - => DiffTime - -> StrictTVar m (PeerStates m addr) - -> m () -cleanPeerStates interval v = go - where - go = do - threadDelay interval - t <- getMonotonicTime - continue <- atomically $ do - s <- readTVar v - case s of - ThrowException _ - -> pure False - PeerStates ps - -> True <$ (writeTVar v $! (PeerStates $ Map.mapMaybe (cleanPeerState t) ps)) - - if continue - then go - else pure () - - - cleanPeerState :: Time -> PeerState m -> Maybe (PeerState m) - cleanPeerState _t ColdPeer{} = Nothing - cleanPeerState _ ps@HotPeer{} = Just ps - cleanPeerState t ps@(SuspendedConsumer producers consT) - | Set.null producers && consT >= t - -- the consumer is not suspended anymore, but there is no producer thread - -- running, we can safely remove the peer from 'PeerStates' - = Nothing - - | consT >= t - -- the consumer is not suspended anymore, there are running producer - -- threads, and thus return a 'HotPeer'. - = Just (HotPeer producers Set.empty) - - | otherwise - -- otherwise the consumer is still supsended - = Just ps - - cleanPeerState t ps@(SuspendedPeer prodT consT) - | prodT < t - -- the producer is still suspended - = Just ps - - | consT < t - -- only the consumer is still suspended - = Just (SuspendedConsumer Set.empty consT) - - | otherwise - -- the peer is not suspended any more - = Nothing - - - --- | Update 'PeerStates' for a given 'addr', using 'suspend', and return --- threads which must be cancelled. --- --- This is more efficient that using the action of 'SuspendDecision' on --- 'PeerStates', since it only uses a single dictionary lookup to update the --- state and return the set of threads to be cancelled. --- -runSuspendDecision - :: forall m addr e. - ( Ord addr - , Ord (Async m ()) - , Exception e - ) - => Time - -> addr - -> e - -> SuspendDecision DiffTime - -> PeerStates m addr - -> ( PeerStates m addr - , Set (Async m ()) - ) -runSuspendDecision _t _addr _e _cmd ps0@ThrowException{} = - ( ps0 - , Set.empty - ) -runSuspendDecision _t _addr e Throw _ = - ( ThrowException (SomeException e) - , Set.empty - ) -runSuspendDecision t addr _e cmd (PeerStates ps0) = - gn $ alterAndLookup fn addr ps0 - where - fn :: Maybe (PeerState m) - -> ( Set (Async m ()) - , Maybe (PeerState m) - ) - fn mbps = ( maybe Set.empty (`threadsToCancel` cmd) mbps - , mbps <| (flip addTime t <$> cmd) - ) - - gn :: ( Map addr (PeerState m) - , Maybe (Set (Async m ())) - ) - -> ( PeerStates m addr - , Set (Async m ()) - ) - gn (ps, Nothing) = (PeerStates ps, Set.empty) - gn (ps, Just s) = (PeerStates ps, s) - - - --- Using pure 'State' monad and 'alterF' to avoid searching the 'PeerState' --- twice. -alterAndLookup - :: forall k s a. - Ord k - => (Maybe a -> (s, Maybe a)) - -> k - -> Map k a - -> ( Map k a - , Maybe s - ) -alterAndLookup f k m = runState (Map.alterF g k m) Nothing - where - g :: Maybe a -> State (Maybe s) (Maybe a) - g mba = case f mba of - (s, mba') -> mba' <$ modify' (const (Just s)) - - --- --- Various callbacks --- - - --- | Register producer in PeerStates. This is a partial function which assumes --- that the 'PeerState' is either 'HotPeer' or 'SuspendedConsumer'. --- -registerProducer :: forall m addr. - ( Ord addr - , Ord (Async m ()) - ) - => addr - -> Async m () - -> PeerStates m addr - -> PeerStates m addr -registerProducer _addr _tid ps@ThrowException{} = ps -registerProducer addr tid (PeerStates peerStates) = - PeerStates $ Map.alter fn addr peerStates - where - fn :: Maybe (PeerState m) -> Maybe (PeerState m) - fn Nothing = - Just (HotPeer (Set.singleton tid) Set.empty) - fn (Just (HotPeer producers consumers)) = - Just (HotPeer (tid `Set.insert` producers) consumers) - fn (Just ColdPeer) = - Just (HotPeer (Set.singleton tid) Set.empty) - fn (Just (SuspendedConsumer producers consT)) = - Just (SuspendedConsumer (tid `Set.insert` producers) consT) - fn (Just ps@SuspendedPeer{}) = - -- registerProducer on a suspended peer - assert False $ Just ps - -unregisterProducer :: forall m addr. - ( Ord addr - , Ord (Async m ()) - ) - => addr - -> Async m () - -> PeerStates m addr - -> PeerStates m addr -unregisterProducer _addr _tid ps@ThrowException{} = ps -unregisterProducer addr tid (PeerStates peerStates) = - PeerStates $ Map.alter fn addr peerStates - where - fn :: Maybe (PeerState m) -> Maybe (PeerState m) - fn Nothing = Nothing - fn (Just (HotPeer producers consumers)) = - let producers' = tid `Set.delete` producers - in if Set.null producers' && Set.null consumers - then Nothing - else Just (HotPeer producers' consumers) - fn (Just ColdPeer) = Nothing - fn (Just p@SuspendedPeer{}) = Just p - fn (Just (SuspendedConsumer producers consT)) = - Just (SuspendedConsumer (tid `Set.delete` producers) consT) - - --- | Register consumer in 'PeerState'. This is a partial function which --- assumes that the 'PeerState' is 'HotPeer'. --- -registerConsumer :: forall m addr. - ( Ord addr - , Ord (Async m ()) - ) - => addr - -> Async m () - -> PeerStates m addr - -> PeerStates m addr -registerConsumer _addr _tid ps@ThrowException{} = ps -registerConsumer addr tid (PeerStates peerStates) = - PeerStates $ Map.alter fn addr peerStates - where - fn :: Maybe (PeerState m) -> Maybe (PeerState m) - fn Nothing = - Just (HotPeer Set.empty (Set.singleton tid)) - fn (Just (HotPeer producers consumers)) = - Just (HotPeer producers (tid `Set.insert` consumers)) - fn (Just ColdPeer) = - Just (HotPeer Set.empty (Set.singleton tid)) - fn (Just ps) = - -- registerConsumer on a suspended peer - assert False $ Just ps - - --- | Unregister consumer from a 'PeerState'. --- -unregisterConsumer :: forall m addr. - ( Ord addr - , Ord (Async m ()) - ) - => addr - -> Async m () - -> PeerStates m addr - -> PeerStates m addr -unregisterConsumer _addr _tid ps@ThrowException{} = ps -unregisterConsumer addr tid (PeerStates peerStates) = - PeerStates $ Map.alter fn addr peerStates - where - fn :: Maybe (PeerState m) -> Maybe (PeerState m) - fn Nothing = Nothing - fn (Just (HotPeer producers consumers)) = - let consumers' = tid `Set.delete` consumers - in if Set.null producers && Set.null consumers' - then Nothing - else Just (HotPeer producers consumers') - fn (Just ColdPeer) = Nothing - fn (Just ps) = Just ps - - --- | Before connectin with a peer we make a decision to either connect to it or --- not. --- -data ConnectDecision s - = AllowConnection !s - | DisallowConnection !s - | OnlyAccept !s - deriving Functor - --- | Check state before connecting to a remote peer. We will connect only if --- it retuns 'True'. --- -type BeforeConnect m s addr = Time -> addr -> s -> STM m (ConnectDecision s) - --- | Run 'BeforeConnect' callback in a 'MonadTime' monad. --- -runBeforeConnect :: ( MonadMonotonicTime m - , MonadSTM m - ) - => StrictTVar m s - -> BeforeConnect m s addr - -> addr - -> m Bool -runBeforeConnect sVar beforeConnect addr = do - t <- getMonotonicTime - atomically $ do - d <- readTVar sVar >>= beforeConnect t addr - case d of - AllowConnection s -> True <$ writeTVar sVar s - DisallowConnection s -> False <$ writeTVar sVar s - OnlyAccept s -> False <$ writeTVar sVar s - - --- | 'BeforeConnect' callback: it updates peer state and return boolean value --- wheather to connect to it or not. If a peer hasn't been recorded in --- 'PeerStates', we add it and try to connect to it. --- -beforeConnectTx - :: forall m addr. - ( MonadSTM m - , Ord addr - ) - => BeforeConnect m - (PeerStates m addr) - addr - -beforeConnectTx _t _addr ps@ThrowException{} = pure $ DisallowConnection ps - -beforeConnectTx t addr (PeerStates s) = - case alterAndLookup fn addr s of - (s', mbd) -> case mbd of - Nothing -> pure $ DisallowConnection (PeerStates s') - Just d -> pure (PeerStates s' <$ d) - where - fn :: Maybe (PeerState m) - -> ( ConnectDecision () - , Maybe (PeerState m) - ) - - -- we see the peer for the first time; consider it as a good peer and - -- try to connect to it. - fn Nothing = ( AllowConnection () - , Just ColdPeer - ) - - fn (Just p@ColdPeer{}) = ( AllowConnection () - , Just p - ) - - fn (Just p@(HotPeer producers consumers)) - = if Set.null producers && Set.null consumers - -- the peer has no registered producers nor consumers, thus it should - -- be marked as a 'ColdPeer' - then ( AllowConnection () - , Just ColdPeer - ) - else ( AllowConnection () - , Just p - ) - - fn (Just p@(SuspendedConsumer producers consT)) = - if consT < t - then if Set.null producers - -- the consumer is not suspended any longer, and it has no - -- producers; thus it's a 'ColdPeer'. - then (AllowConnection (), Just ColdPeer) - else (AllowConnection (), Just (HotPeer producers Set.empty)) - else (DisallowConnection (), Just p) - - fn (Just p@(SuspendedPeer prodT consT)) = - if t < prodT `max` consT - then if t < prodT `min` consT - then (DisallowConnection (), Just p) - else if prodT < consT - then -- prodT ≤ t < consT - -- allow the remote peer to connect to us, but we're - -- still not allowed to connect to it. - (OnlyAccept (), Just $ SuspendedConsumer Set.empty consT) - else -- consT ≤ t < prodT - -- the local consumer is suspended shorter than local - -- producer; In this case we suspend both until `prodT`. - -- This means we effectively make local consumer - -- errors more sevier than the ones which come from - -- a local producer. - (DisallowConnection (), Just $ SuspendedPeer prodT prodT) - - -- the peer is not suspended any longer - else (AllowConnection (), Just ColdPeer) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Subscriber.hs b/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Subscriber.hs deleted file mode 100644 index 464257f9b8d..00000000000 --- a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Subscriber.hs +++ /dev/null @@ -1,21 +0,0 @@ - -module Ouroboros.Network.Subscription.Subscriber - ( SubscriptionTarget (..) - , listSubscriptionTarget - ) where - --- | Generate subscription targets in some monad. --- Examples include obtaining targets from a fixed list, or from a DNS lookup. -newtype SubscriptionTarget m target = SubscriptionTarget - { getSubscriptionTarget :: m (Maybe (target, SubscriptionTarget m target)) - -- ^ This should be used with the exception that implementations can block on - -- the order of seconds. - } - -listSubscriptionTarget - :: Applicative m - => [target] - -> SubscriptionTarget m target -listSubscriptionTarget [] = SubscriptionTarget $ pure Nothing -listSubscriptionTarget (t:ts) = SubscriptionTarget $ pure (Just (t, listSubscriptionTarget ts)) - diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Worker.hs b/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Worker.hs deleted file mode 100644 index 8d0563e7d3a..00000000000 --- a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Worker.hs +++ /dev/null @@ -1,670 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Ouroboros.Network.Subscription.Worker - ( SocketStateChange - , SocketState (..) - , CompleteApplication - , ConnectResult (..) - , Result (..) - , Main - , StateVar - , LocalAddresses (..) - -- * Subscription worker - , WorkerCallbacks (..) - , WorkerParams (..) - , worker - -- * Socket API - , safeConnect - -- * Constants - , defaultConnectionAttemptDelay - , minConnectionAttemptDelay - , maxConnectionAttemptDelay - , ipRetryDelay - -- * Errors - , SubscriberError (..) - -- * Tracing - , SubscriptionTrace (..) - ) where - -import Control.Applicative ((<|>)) -import Control.Concurrent.STM qualified as STM -import Control.Exception (SomeException (..)) -import Control.Monad (forever, join, unless, when) -import Control.Monad.Fix (MonadFix) -import Data.Foldable (traverse_) -import Data.Set (Set) -import Data.Set qualified as Set -import Data.Void (Void) -import GHC.Stack -import Network.Socket (Family (AF_UNIX)) -import Text.Printf - -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime.SI -import Control.Monad.Class.MonadTimer.SI -import Control.Tracer - -import Ouroboros.Network.ErrorPolicy (CompleteApplication, - CompleteApplicationResult (..), ErrorPolicyTrace, Result (..), - WithAddr) -import Ouroboros.Network.Server.ConnectionTable -import Ouroboros.Network.Snocket (Snocket (..)) -import Ouroboros.Network.Snocket qualified as Snocket -import Ouroboros.Network.Subscription.Subscriber - --- | Time to wait between connection attempts when we don't have any DeltaQ --- info. --- -defaultConnectionAttemptDelay :: DiffTime -defaultConnectionAttemptDelay = 0.025 -- 25ms delay - --- | Minimum time to wait between connection attempts. --- -minConnectionAttemptDelay :: DiffTime -minConnectionAttemptDelay = 0.010 -- 10ms delay - --- | Maximum time to wait between connection attempts. --- -maxConnectionAttemptDelay :: DiffTime -maxConnectionAttemptDelay = 2 -- 2s delay - --- | Minimum time to wait between ip reconnects --- -ipRetryDelay :: DiffTime -ipRetryDelay = 10 -- 10s delay - -data ResOrAct m addr tr r = - Res !(Result addr r) - | Act (Set (Async m ())) -- ^ threads to kill - (Maybe tr) -- ^ trace point - --- | Result queue. The spawned threads will keep writing to it, while the main --- server will read from it. --- -type ResultQ m addr tr r = StrictTQueue m (ResOrAct m addr tr r) - -newResultQ :: forall m addr tr r. MonadSTM m => m (ResultQ m addr tr r) -newResultQ = atomically $ newTQueue - --- | Mutable state kept by the worker. All the workers in this module are --- polymorphic over the state type. The state is updated with two callbacks: --- --- * 'CompleteConnect' - STM transaction which runs when the connect call --- returned, if it thrown an exception it will be --- passed to the callback. --- * 'CompleteApplication' - STM transaction which runs when application --- returned. It will receive the result of the --- application or an exception raised by it. --- -type StateVar m s = StrictTVar m s - --- | The set of all spawned threads. Used for waiting or cancelling them when --- the server shuts down. --- -type ThreadsVar m = StrictTVar m (Set (Async m ())) - - -data SocketState m addr - = CreatedSocket !addr !(Async m ()) - | ClosedSocket !addr !(Async m ()) - --- | Callback which fires: when we create or close a socket. --- -type SocketStateChange m s addr = SocketState m addr -> s -> STM m s - --- | Given current state 'retry' too keep the subscription worker going. --- When this transaction returns, all the threads spawned by the worker will be --- killed. --- -type Main m s t = s -> STM m t - -data LocalAddresses addr = LocalAddresses { - -- | Local IPv4 address to use, Nothing indicates don't use IPv4 - laIpv4 :: Maybe addr - -- | Local IPv6 address to use, Nothing indicates don't use IPv6 - , laIpv6 :: Maybe addr - -- | Local Unix address to use, Nothing indicates don't use Unix sockets - , laUnix :: Maybe addr - } deriving (Eq, Show) - -instance Semigroup (LocalAddresses addr) where - a <> b = LocalAddresses { - laIpv4 = laIpv4 a <|> laIpv4 b, - laIpv6 = laIpv6 a <|> laIpv6 b, - laUnix = laUnix a <|> laUnix b - } - - --- | Allocate a socket and connect to a peer, execute the continuation with --- async exceptions masked. The continuation receives the 'unmask' callback. --- -safeConnect :: ( MonadMask m - ) - => Snocket m sock addr - -> (sock -> addr -> m ()) -- ^ configure the socket - -> addr - -- ^ remote addr - -> addr - -- ^ local addr - -> m () - -- ^ allocate extra action; executed with async exceptions masked in - -- the allocation action of 'bracket' - -> m () - -- ^ release extra action; executed with async exceptions masked in - -- the closing action of 'bracket' - -> ((forall x. m x -> m x) -> sock -> Either SomeException () -> m t) - -- ^ continuation executed with async exceptions - -- masked; it receives: unmask function, allocated socket and - -- connection error. - -> m t -safeConnect sn configureSock remoteAddr localAddr malloc mclean k = - bracket - (do sock <- Snocket.open sn (Snocket.addrFamily sn remoteAddr) - malloc - pure sock - ) - (\sock -> Snocket.close sn sock >> mclean) - (\sock -> mask $ \unmask -> do - res <- try $ do - configureSock sock localAddr - let doBind = case Snocket.addrFamily sn localAddr of - Snocket.SocketFamily fam -> fam /= AF_UNIX - _ -> False -- Bind is a nop for Named Pipes anyway - when doBind $ - Snocket.bind sn sock localAddr - unmask $ Snocket.connect sn sock remoteAddr - k unmask sock res) - - --- --- Internal API --- - - --- | GADT which classifies connection result. --- -data ConnectResult = - ConnectSuccess - -- ^ Successful connection. - | ConnectSuccessLast - -- ^ Successfully connection, reached the valency target. Other ongoing - -- connection attempts will be killed. - | ConnectValencyExceeded - -- ^ Someone else manged to create the final connection to a target before - -- us. - deriving (Eq, Ord, Show) - --- | Traverse 'SubscriptionTarget's in an infinite loop. --- -subscriptionLoop - :: forall m s sock localAddrs addr a x. - ( MonadAsync m - , MonadDelay m - , MonadMask m - , MonadFix m - , Ord (Async m ()) - , Ord addr - ) - => Tracer m (SubscriptionTrace addr) - - -- various state variables of the subscription loop - -> ConnectionTable m addr - -> ResultQ m addr (WithAddr addr ErrorPolicyTrace) a - -> StateVar m s - -> ThreadsVar m - - -> Snocket m sock addr - -> (sock -> addr -> m ()) - - -> WorkerCallbacks m s addr a x - -> WorkerParams m localAddrs addr - -- ^ given a remote address, pick the local one - -> (sock -> m a) - -- ^ application - -> m Void -subscriptionLoop - tr tbl resQ sVar threadsVar snocket configureSock - WorkerCallbacks { wcSocketStateChangeTx = socketStateChangeTx - , wcCompleteApplicationTx = completeApplicationTx - } - WorkerParams { wpLocalAddresses = localAddresses - , wpConnectionAttemptDelay = connectionAttemptDelay - , wpSubscriptionTarget = subscriptionTargets - , wpValency = valency - , wpSelectAddress - } - k = do - valencyVar <- atomically $ newValencyCounter tbl valency - - -- outer loop: set new 'conThread' variable, get targets and traverse - -- through them trying to connect to each addr. - forever $ do - traceWith tr (SubscriptionTraceStart valency) - start <- getMonotonicTime - conThreads <- newTVarIO Set.empty - sTarget <- subscriptionTargets - innerLoop conThreads valencyVar sTarget - atomically $ waitValencyCounter valencyVar - - -- We always wait at least 'ipRetryDelay' seconds between calls to - -- 'getTargets', and before trying to restart the subscriptions we also - -- wait 1 second so that if multiple subscription targets fail around the - -- same time we will try to restart with a valency - -- higher than 1. - threadDelay 1 - end <- getMonotonicTime - let duration = diffTime end start - currentValency <- atomically $ readValencyCounter valencyVar - traceWith tr $ SubscriptionTraceRestart duration valency - (valency - currentValency) - - when (duration < ipRetryDelay) $ - threadDelay $ ipRetryDelay - duration - - where - -- a single run through @sTarget :: SubscriptionTarget m addr@. - innerLoop :: StrictTVar m (Set (Async m ())) - -> ValencyCounter m - -> SubscriptionTarget m addr - -> m () - innerLoop conThreads valencyVar sTarget = do - mt <- getSubscriptionTarget sTarget - case mt of - Nothing -> do - len <- fmap length $ atomically $ readTVar conThreads - when (len > 0) $ - traceWith tr $ SubscriptionTraceSubscriptionWaiting len - - -- We wait on the list of active connection threads instead of using - -- an async wait function since some of the connections may succeed - -- and then should be left running. - -- - -- Note: active connections are removed from 'conThreads' when the - -- 'connect' call finishes. - atomically $ do - activeCons <- readTVar conThreads - unless (null activeCons) retry - - valencyLeft <- atomically $ readValencyCounter valencyVar - if valencyLeft <= 0 - then traceWith tr SubscriptionTraceSubscriptionRunning - else traceWith tr SubscriptionTraceSubscriptionFailed - - Just (remoteAddr, sTargetNext) -> do - valencyLeft <- atomically $ readValencyCounter valencyVar - - -- If we have already created enough connections (valencyLeft <= 0) - -- we don't need to traverse the rest of the list. - if valencyLeft <= 0 - then traceWith tr SubscriptionTraceSubscriptionRunning - else innerStep conThreads valencyVar remoteAddr sTargetNext - - innerStep :: StrictTVar m (Set (Async m ())) - -- ^ outstanding connection threads; threads are removed as soon - -- as the connection succeeds. They are all cancelled when - -- valency drops to 0. The asynchronous exception which cancels - -- the connection thread can only occur while connecting and not - -- when an application is running. This is guaranteed since - -- threads are removed from this set as soon connecting is - -- finished (successfully or not) and before application is - -- started. - -> ValencyCounter m - -> addr - -> SubscriptionTarget m addr - -> m () - innerStep conThreads valencyVar !remoteAddr sTargetNext = do - r <- refConnection tbl remoteAddr ConnectionOutbound valencyVar - case r of - ConnectionTableCreate -> - case wpSelectAddress remoteAddr localAddresses of - Nothing -> - traceWith tr (SubscriptionTraceUnsupportedRemoteAddr remoteAddr) - - -- This part is very similar to - -- 'Ouroboros.Network.Server.Socket.spawnOne', it should not - -- deadlock by the same reasons. The difference is that we are - -- using 'mask' and 'async' as 'asyncWithUnmask' is not available. - Just localAddr -> - do rec - thread <- async $ do - traceWith tr $ SubscriptionTraceConnectStart remoteAddr - -- Try to connect; 'safeConnect' is using 'bracket' to - -- create / close a socket and update the states. The - -- continuation, e.g. 'connAction' runs with async - -- exceptions masked, and receives the unmask function from - -- this bracket. - safeConnect - snocket - configureSock - remoteAddr - localAddr - (do - traceWith tr $ SubscriptionTraceAllocateSocket remoteAddr - atomically $ do - modifyTVar conThreads (Set.insert thread) - modifyTVar threadsVar (Set.insert thread) - readTVar sVar - >>= socketStateChangeTx (CreatedSocket remoteAddr thread) - >>= (writeTVar sVar $!)) - (do - atomically $ do - -- The thread is removed from 'conThreads' - -- inside 'connAction'. - modifyTVar threadsVar (Set.delete thread) - readTVar sVar - >>= socketStateChangeTx (ClosedSocket remoteAddr thread) - >>= (writeTVar sVar $!) - traceWith tr $ SubscriptionTraceCloseSocket remoteAddr) - (connAction - thread conThreads valencyVar - remoteAddr) - - let delay = case connectionAttemptDelay remoteAddr of - Just d -> d `max` minConnectionAttemptDelay - `min` maxConnectionAttemptDelay - Nothing -> defaultConnectionAttemptDelay - traceWith tr - (SubscriptionTraceSubscriptionWaitingNewConnection delay) - threadDelay delay - - ConnectionTableExist -> - traceWith tr $ SubscriptionTraceConnectionExist remoteAddr - ConnectionTableDuplicate -> pure () - innerLoop conThreads valencyVar sTargetNext - - -- Start connection thread: connect to the remote peer, run application. - -- This function runs with asynchronous exceptions masked. - -- - connAction :: Async m () - -> StrictTVar m (Set (Async m ())) - -> ValencyCounter m - -> addr - -> (forall y. m y -> m y) -- unmask exceptions - -> sock - -> Either SomeException () - -> m () - connAction thread conThreads valencyVar remoteAddr unmask sock connectionRes = do - t <- getMonotonicTime - case connectionRes of - -- connection error - Left (SomeException e) -> do - traceWith tr $ SubscriptionTraceConnectException remoteAddr e - atomically $ do - -- remove thread from active connections threads - modifyTVar conThreads (Set.delete thread) - - CompleteApplicationResult - { carState - , carThreads - , carTrace - } <- readTVar sVar >>= completeApplicationTx (ConnectionError t remoteAddr e) - writeTVar sVar carState - writeTQueue resQ (Act carThreads carTrace) - - -- connection succeeded - Right _ -> do - localAddr <- Snocket.getLocalAddr snocket sock - connRes <- atomically $ do - -- we successfully connected, remove the thread from - -- outstanding connection threads. - modifyTVar conThreads (Set.delete thread) - - v <- readValencyCounter valencyVar - if v > 0 - then do - addConnection tbl remoteAddr localAddr ConnectionOutbound (Just valencyVar) - CompleteApplicationResult - { carState - , carThreads - , carTrace - } <- readTVar sVar >>= completeApplicationTx (Connected t remoteAddr) - writeTVar sVar carState - writeTQueue resQ (Act carThreads carTrace) - return $ if v == 1 - then ConnectSuccessLast - else ConnectSuccess - else - return ConnectValencyExceeded - - -- handle connection result - traceWith tr $ SubscriptionTraceConnectEnd remoteAddr connRes - case connRes of - ConnectValencyExceeded -> pure () - -- otherwise it was a success - _ -> do - when (connRes == ConnectSuccessLast) $ do - -- outstanding connection threads - threads <- atomically $ readTVar conThreads - mapM_ (\tid -> - cancelWith tid - (SubscriberError - SubscriberParallelConnectionCancelled - "Parallel connection cancelled" - callStack) - )threads - - - -- run application - appRes :: Either SomeException a - <- try $ unmask (k sock) - - case appRes of - Right _ -> pure () - Left e -> traceWith tr $ SubscriptionTraceApplicationException remoteAddr e - - t' <- getMonotonicTime - atomically $ do - case appRes of - Right a -> - writeTQueue resQ (Res (ApplicationResult t' remoteAddr a)) - Left (SomeException e) -> - writeTQueue resQ (Res (ApplicationError t' remoteAddr e)) - removeConnectionSTM tbl remoteAddr localAddr ConnectionOutbound - --- | Almost the same as 'Ouroboros.Network.Server.Socket.mainLoop'. --- 'mainLoop' reads from the result queue and runs the 'CompleteApplication' --- callback. --- -mainLoop - :: forall s r addr t. - Tracer IO (WithAddr addr ErrorPolicyTrace) - -> ResultQ IO addr (WithAddr addr ErrorPolicyTrace) r - -> ThreadsVar IO - -> StateVar IO s - -> CompleteApplication IO s addr r - -> Main IO s t - -> IO t -mainLoop errorPolicyTracer resQ threadsVar statusVar completeApplicationTx main = do - join (atomically $ mainTx `STM.orElse` connectionTx) - where - -- Sample the state, and run the main action. If it does not retry, then - -- the `mainLoop` finishes with `pure t` where `t` is the main action result. - mainTx :: STM IO (IO t) - mainTx = do - t <- readTVar statusVar >>= main - pure $ pure t - - -- Wait for some connection to finish, update the state with its result, - -- then recurse onto `mainLoop`. - connectionTx :: STM IO (IO t) - connectionTx = do - result <- readTQueue resQ - case result of - Act threads tr -> pure $ do - traverse_ cancel threads - traverse_ (traceWith errorPolicyTracer) tr - mainLoop errorPolicyTracer resQ threadsVar statusVar completeApplicationTx main - Res r -> do - s <- readTVar statusVar - CompleteApplicationResult - { carState - , carThreads - , carTrace - } <- completeApplicationTx r s - writeTVar statusVar carState - pure $ do - traverse_ cancel carThreads - traverse_ (traceWith errorPolicyTracer) carTrace - mainLoop errorPolicyTracer resQ threadsVar statusVar completeApplicationTx main - - --- --- Worker --- - --- | Worker STM callbacks --- -data WorkerCallbacks m s addr a t = WorkerCallbacks { - wcSocketStateChangeTx :: SocketStateChange m s addr, - wcCompleteApplicationTx :: CompleteApplication m s addr a, - wcMainTx :: Main m s t - } - --- | Worker parameters --- -data WorkerParams m localAddrs addr = WorkerParams { - wpLocalAddresses :: localAddrs addr, - -- ^ local addresses of the server - wpSelectAddress :: addr -> localAddrs addr -> Maybe addr, - -- ^ given remote addr pick the local address - wpConnectionAttemptDelay :: addr -> Maybe DiffTime, - -- ^ delay after a connection attempt to 'addr' - wpSubscriptionTarget :: m (SubscriptionTarget m addr), - wpValency :: Int - } - --- | This is the most abstract worker, which puts all the pieces together. It --- will execute until @main :: Main m s t@ returns. It runs --- 'subscriptionLoop' in a new threads and will exit when it dies. Spawn --- threads are cancelled in a 'finally' callback by throwing 'SubscriberError'. --- --- Note: This function runs in 'IO' only because 'MonadSTM' does not yet support --- 'orElse', PR #432. --- -worker - :: forall s sock localAddrs addr a x. - Ord addr - => Tracer IO (SubscriptionTrace addr) - -> Tracer IO (WithAddr addr ErrorPolicyTrace) - -> ConnectionTable IO addr - -> StateVar IO s - - -> Snocket IO sock addr - -> (sock -> addr -> IO ()) - - -> WorkerCallbacks IO s addr a x - -> WorkerParams IO localAddrs addr - - -> (sock -> IO a) - -- ^ application - -> IO x -worker tr errTrace tbl sVar snocket configureSock workerCallbacks@WorkerCallbacks {wcCompleteApplicationTx, wcMainTx } workerParams k = do - resQ <- newResultQ - threadsVar <- newTVarIO Set.empty - withAsync - (subscriptionLoop tr tbl resQ sVar threadsVar snocket configureSock - workerCallbacks workerParams k) $ \_ -> - mainLoop errTrace resQ threadsVar sVar wcCompleteApplicationTx wcMainTx - `finally` killThreads threadsVar - where - killThreads threadsVar = do - let e = SubscriberError - SubscriberWorkerCancelled - "SubscriptionWorker exiting" - callStack - children <- atomically $ readTVar threadsVar - mapM_ (\a -> cancelWith a e) children - - --- --- Auxiliary types: errors, traces --- - -data SubscriberError = SubscriberError { - seType :: !SubscriberErrorType - , seMessage :: !String - , seStack :: !CallStack - } deriving Show - --- | Enumeration of error conditions. --- -data SubscriberErrorType = SubscriberParallelConnectionCancelled - | SubscriberWorkerCancelled - deriving (Eq, Show) - -instance Exception SubscriberError where - displayException SubscriberError{seType, seMessage, seStack} - = printf "%s %s at %s" - (show seType) - (show seMessage) - (prettyCallStack seStack) - - -data SubscriptionTrace addr = - SubscriptionTraceConnectStart addr - | SubscriptionTraceConnectEnd addr ConnectResult - | forall e. Exception e => SubscriptionTraceSocketAllocationException addr e - | forall e. Exception e => SubscriptionTraceConnectException addr e - | forall e. Exception e => SubscriptionTraceApplicationException addr e - | SubscriptionTraceTryConnectToPeer addr - | SubscriptionTraceSkippingPeer addr - | SubscriptionTraceSubscriptionRunning - | SubscriptionTraceSubscriptionWaiting Int - | SubscriptionTraceSubscriptionFailed - | SubscriptionTraceSubscriptionWaitingNewConnection DiffTime - | SubscriptionTraceStart Int - | SubscriptionTraceRestart DiffTime Int Int - | SubscriptionTraceConnectionExist addr - | SubscriptionTraceUnsupportedRemoteAddr addr - | SubscriptionTraceMissingLocalAddress - | SubscriptionTraceAllocateSocket addr - | SubscriptionTraceCloseSocket addr - -instance Show addr => Show (SubscriptionTrace addr) where - show (SubscriptionTraceConnectStart dst) = - "Connection Attempt Start, destination " ++ show dst - show (SubscriptionTraceConnectEnd dst res) = - "Connection Attempt End, destination " ++ show dst ++ " outcome: " ++ show res - show (SubscriptionTraceSocketAllocationException dst e) = - "Socket Allocation Exception, destination " ++ show dst ++ " exception: " ++ show e - show (SubscriptionTraceConnectException dst e) = - "Connection Attempt Exception, destination " ++ show dst ++ " exception: " ++ show e - show (SubscriptionTraceTryConnectToPeer addr) = - "Trying to connect to " ++ show addr - show (SubscriptionTraceSkippingPeer addr) = - "Skipping peer " ++ show addr - show SubscriptionTraceSubscriptionRunning = - "Required subscriptions started" - show (SubscriptionTraceSubscriptionWaiting d) = - "Waiting on " ++ show d ++ " active connections" - show SubscriptionTraceSubscriptionFailed = - "Failed to start all required subscriptions" - show (SubscriptionTraceSubscriptionWaitingNewConnection delay) = - "Waiting " ++ show delay ++ " before attempting a new connection" - show (SubscriptionTraceStart val) = "Starting Subscription Worker, valency " ++ show val - show (SubscriptionTraceRestart duration desiredVal currentVal) = - "Restarting Subscription after " ++ show duration ++ " desired valency " ++ - show desiredVal ++ " current valency " ++ show currentVal - show (SubscriptionTraceConnectionExist dst) = - "Connection Existed to " ++ show dst - show (SubscriptionTraceUnsupportedRemoteAddr dst) = - "Unsupported remote target address " ++ show dst - -- TODO: add address family - show SubscriptionTraceMissingLocalAddress = - "Missing local address" - show (SubscriptionTraceApplicationException addr e) = - "Application Exception: " ++ show addr ++ " " ++ show e - show (SubscriptionTraceAllocateSocket addr) = - "Allocate socket to " ++ show addr - show (SubscriptionTraceCloseSocket addr) = - "Closed socket to " ++ show addr diff --git a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs index a6a49ee14e6..e530d4bf28a 100644 --- a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs +++ b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs @@ -92,9 +92,9 @@ import Ouroboros.Network.Protocol.Handshake.Unversioned import Ouroboros.Network.Protocol.Handshake.Version (Acceptable (..), Queryable (..)) import Ouroboros.Network.RethrowPolicy +import Ouroboros.Network.Server (RemoteTransitionTrace) +import Ouroboros.Network.Server qualified as Server import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) -import Ouroboros.Network.Server2 (RemoteTransitionTrace) -import Ouroboros.Network.Server2 qualified as Server import Ouroboros.Network.Snocket (Snocket) import Ouroboros.Network.Snocket qualified as Snocket diff --git a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/InboundGovernor/Utils.hs b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/InboundGovernor/Utils.hs index 74bf45c8fc8..c7204ce774d 100644 --- a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/InboundGovernor/Utils.hs +++ b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/InboundGovernor/Utils.hs @@ -11,8 +11,8 @@ import Test.QuickCheck.Monoids import Ouroboros.Network.ConnectionManager.Types import Ouroboros.Network.InboundGovernor (RemoteSt (..)) import Ouroboros.Network.InboundGovernor qualified as IG -import Ouroboros.Network.Server2 (RemoteTransition) -import Ouroboros.Network.Server2 qualified as Server +import Ouroboros.Network.Server (RemoteTransition) +import Ouroboros.Network.Server qualified as Server -- | Pattern synonym which matches either 'RemoteHotEst' or 'RemoteWarmSt'. diff --git a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/Server.hs b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/Server.hs new file mode 100644 index 00000000000..1af57b64639 --- /dev/null +++ b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/Server.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | A simple server implemented for testing purposes +-- +-- The module should be imported qualified. +module Test.Ouroboros.Network.Server where + +import Control.Applicative (Alternative) +import Control.Concurrent.JobPool qualified as JobPool +import Control.Monad (forever) +import Control.Monad.Class.MonadAsync +import Control.Monad.Class.MonadFork (MonadFork) +import Control.Monad.Class.MonadSTM +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTimer.SI (MonadTimer) +import Control.Tracer (nullTracer) +import Data.ByteString.Lazy qualified as BL +import Data.Functor (void) +import Data.Typeable (Typeable) +import Data.Void (Void) + +import Network.Mux qualified as Mx + +import Ouroboros.Network.ConnectionId +import Ouroboros.Network.Mux +import Ouroboros.Network.Protocol.Handshake +import Ouroboros.Network.Snocket as Snocket +import Ouroboros.Network.Socket + + +with :: forall fd addr vNumber vData m a b. + ( Alternative (STM m), + MonadAsync m, + MonadFork m, + MonadLabelledSTM m, + MonadMask m, + MonadTimer m, + MonadThrow (STM m), + Ord vNumber, + Typeable vNumber, + Show vNumber + ) + => Snocket m fd addr + -> Mx.MakeBearer m fd + -> (fd -> addr -> m ()) + -> addr + -> HandshakeArguments (ConnectionId addr) vNumber vData m + -> Versions vNumber vData (SomeResponderApplication addr BL.ByteString m b) + -> (addr -> Async m Void -> m a) + -> m a +with sn makeBearer configureSock addr handshakeArgs versions k = + JobPool.withJobPool $ \jobPool -> + bracket + (do sd <- Snocket.open sn (Snocket.addrFamily sn addr) + configureSock sd addr + Snocket.bind sn sd addr + Snocket.listen sn sd + addr' <- getLocalAddr sn sd + pure (sd, addr')) + (Snocket.close sn . fst) + (\(sock, addr') -> + -- accept loop + withAsync (forever $ acceptOne jobPool sock) (k addr') + ) + where + acceptOne :: JobPool.JobPool () m () -> fd -> m () + acceptOne jobPool sock = accept sn sock >>= runAccept >>= \case + (Accepted sock' remoteAddr, _) -> do + let connThread = do + -- connection responder thread + let connId = ConnectionId addr remoteAddr + bearer <- Mx.getBearer makeBearer + (-1) nullTracer sock' + configureSock sock' addr + r <- runHandshakeServer bearer connId handshakeArgs versions + case r of + Left (HandshakeProtocolLimit e) -> throwIO e + Left (HandshakeProtocolError e) -> throwIO e + Right HandshakeQueryResult {} -> error "handshake query is not supported" + Right (HandshakeNegotiationResult (SomeResponderApplication app) vNumber vData) -> do + mux <- Mx.new (toMiniProtocolInfos app) + withAsync (Mx.run nullTracer mux bearer) $ \aid -> do + void $ simpleMuxCallback connId vNumber vData app mux aid + + errorHandler = \e -> throwIO e + + JobPool.forkJob jobPool + $ JobPool.Job connThread + errorHandler + () + "conn-thread" + (AcceptFailure e, _) -> throwIO e diff --git a/ouroboros-network-testing/src/Test/Ouroboros/Network/Data/AbsBearerInfo.hs b/ouroboros-network-testing/src/Test/Ouroboros/Network/Data/AbsBearerInfo.hs index 6e59f438593..01f0fd621e9 100644 --- a/ouroboros-network-testing/src/Test/Ouroboros/Network/Data/AbsBearerInfo.hs +++ b/ouroboros-network-testing/src/Test/Ouroboros/Network/Data/AbsBearerInfo.hs @@ -132,14 +132,14 @@ instance Arbitrary AbsIOError where , connectionAbortedError ] where - -- `ECONNABORTED` error which appears in `Ouroboros.Network.Server2` + -- `ECONNABORTED` error which appears in `Ouroboros.Network.Server` connectionAbortedError :: IOError connectionAbortedError = IOError { ioe_handle = Nothing , ioe_type = OtherError , ioe_location = "Ouroboros.Network.Snocket.Sim.accept" -- Note: this matches the `iseCONNABORTED` on Windows, see - -- 'Ouroboros.Network.Server2` + -- 'Ouroboros.Network.Server` , ioe_description = "Software caused connection abort (WSAECONNABORTED)" , ioe_errno = Just (case eCONNABORTED of Errno errno -> errno) , ioe_filename = Nothing diff --git a/ouroboros-network/CHANGELOG.md b/ouroboros-network/CHANGELOG.md index 3c266c546a5..36737fa55b1 100644 --- a/ouroboros-network/CHANGELOG.md +++ b/ouroboros-network/CHANGELOG.md @@ -10,6 +10,22 @@ ### Breaking changes +* APIs removed from `Ouroboros.Network.{NodeToClient,NodeToNode}` modules: + * NetworkServerTracers + * NetworkMutableState APIs + * withServer + * ErrorPolicies + * WithAddr + * SuspendDecision +* APIs removed from `Ouroboros.Network.NodeToNode` module: + * IPSubscriptionTarget + * NetworkIPSubscription + * NetworkSubscriptionTracers + * SubscriptionParams + * DnsSubscriptionTarget + * DnsSubscriptioinParams + * NetworkDNSSubscriptionTracers + * dnsSubscriptionWorker * Added `AcquireConnectionError` to `PeerSelectionActionsTrace` * Removed deprecated `ReconnectDelay` type alias. * Addapted to `network-mux` changes in https://github.com/IntersectMBO/ouroboros-network/pull/4999 diff --git a/ouroboros-network/demo/chain-sync.hs b/ouroboros-network/demo/chain-sync.hs index 042701b820e..83a9ce10af5 100644 --- a/ouroboros-network/demo/chain-sync.hs +++ b/ouroboros-network/demo/chain-sync.hs @@ -59,6 +59,7 @@ import Ouroboros.Network.Snocket import Ouroboros.Network.Socket import Ouroboros.Network.Driver +import Ouroboros.Network.Protocol.Handshake import Ouroboros.Network.Protocol.Handshake.Codec import Ouroboros.Network.Protocol.Handshake.Unversioned import Ouroboros.Network.Protocol.Handshake.Version @@ -78,6 +79,8 @@ import Ouroboros.Network.BlockFetch.ClientRegistry (FetchClientRegistry (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation (..)) import Ouroboros.Network.DeltaQ (defaultGSV) +import Test.Ouroboros.Network.Server qualified as Test.Server + data Options = Options { oBlockFetch :: Bool, @@ -270,25 +273,23 @@ serverChainSync sockAddr slotLength seed = withIOManager $ \iocp -> do prng <- case seed of Nothing -> initStdGen Just a -> return (mkStdGen a) - networkState <- newNetworkMutableState - _ <- async $ cleanNetworkMutableState networkState - withServerNode + Test.Server.with (localSnocket iocp) makeLocalBearer mempty - nullNetworkServerTracers - networkState - (AcceptedConnectionsLimit maxBound maxBound 0) (localAddressFromPath sockAddr) - unversionedHandshakeCodec - noTimeLimitsHandshake - unversionedProtocolDataCodec - (HandshakeCallbacks acceptableVersion queryVersion) + HandshakeArguments { + haHandshakeTracer = nullTracer, + haHandshakeCodec = unversionedHandshakeCodec, + haVersionDataCodec = unversionedProtocolDataCodec, + haAcceptVersion = acceptableVersion, + haQueryVersion = queryVersion, + haTimeLimits = noTimeLimitsHandshake + } (simpleSingletonVersions UnversionedProtocol UnversionedProtocolData (SomeResponderApplication (app prng))) - nullErrorPolicies $ \_ serverAsync -> wait serverAsync -- block until async exception where @@ -544,25 +545,23 @@ serverBlockFetch sockAddr slotLength seed = withIOManager $ \iocp -> do prng <- case seed of Nothing -> initStdGen Just a -> return (mkStdGen a) - networkState <- newNetworkMutableState - _ <- async $ cleanNetworkMutableState networkState - withServerNode + Test.Server.with (localSnocket iocp) makeLocalBearer mempty - nullNetworkServerTracers - networkState - (AcceptedConnectionsLimit maxBound maxBound 0) (localAddressFromPath sockAddr) - unversionedHandshakeCodec - noTimeLimitsHandshake - unversionedProtocolDataCodec - (HandshakeCallbacks acceptableVersion queryVersion) + HandshakeArguments { + haHandshakeTracer = nullTracer, + haHandshakeCodec = unversionedHandshakeCodec, + haVersionDataCodec = unversionedProtocolDataCodec, + haAcceptVersion = acceptableVersion, + haQueryVersion = queryVersion, + haTimeLimits = noTimeLimitsHandshake + } (simpleSingletonVersions UnversionedProtocol UnversionedProtocolData (SomeResponderApplication (app prng))) - nullErrorPolicies $ \_ serverAsync -> wait serverAsync -- block until async exception where diff --git a/ouroboros-network/io-tests/Test/Ouroboros/Network/Socket.hs b/ouroboros-network/io-tests/Test/Ouroboros/Network/Socket.hs index c48bd1a070d..ce8cb3b7483 100644 --- a/ouroboros-network/io-tests/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network/io-tests/Test/Ouroboros/Network/Socket.hs @@ -38,10 +38,12 @@ import Ouroboros.Network.Mock.Chain (Chain, ChainUpdate, Point) import Ouroboros.Network.Mock.Chain qualified as Chain import Ouroboros.Network.Mock.ProducerState qualified as CPS import Ouroboros.Network.NodeToNode +import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) import Ouroboros.Network.Protocol.ChainSync.Client qualified as ChainSync import Ouroboros.Network.Protocol.ChainSync.Codec qualified as ChainSync import Ouroboros.Network.Protocol.ChainSync.Examples qualified as ChainSync import Ouroboros.Network.Protocol.ChainSync.Server qualified as ChainSync +import Ouroboros.Network.Protocol.Handshake (HandshakeArguments (..)) import Ouroboros.Network.Protocol.Handshake.Codec (cborTermVersionDataCodec, noTimeLimitsHandshake) import Ouroboros.Network.Protocol.Handshake.Version (acceptableVersion, @@ -50,8 +52,8 @@ import Ouroboros.Network.Util.ShowProxy import Test.ChainGenerators (TestBlockChainAndUpdates (..)) import Test.Ouroboros.Network.Serialise +import Test.Ouroboros.Network.Server qualified as Test.Server -import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) import Test.QuickCheck import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) @@ -117,8 +119,7 @@ demo chain0 updates = withIOManager $ \iocp -> do producerVar <- newTVarIO (CPS.initChainProducerState chain0) consumerVar <- newTVarIO chain0 - done <- atomically newEmptyTMVar - networkState <- newNetworkMutableState + done <- newEmptyTMVarIO let Just expectedChain = Chain.applyChainUpdates updates chain0 target = Chain.headPoint expectedChain @@ -156,18 +157,20 @@ demo chain0 updates = withIOManager $ \iocp -> do encode decode (encodeTip encode) (decodeTip decode) - withServerNode + Test.Server.with (socketSnocket iocp) makeSocketBearer ((. Just) <$> configureSocket) - nullNetworkServerTracers - networkState - (AcceptedConnectionsLimit maxBound maxBound 0) producerAddress - nodeToNodeHandshakeCodec - noTimeLimitsHandshake - (cborTermVersionDataCodec nodeToNodeCodecCBORTerm) - (HandshakeCallbacks acceptableVersion queryVersion) + HandshakeArguments { + haHandshakeTracer = nullTracer, + haHandshakeCodec = nodeToNodeHandshakeCodec, + haVersionDataCodec = cborTermVersionDataCodec nodeToNodeCodecCBORTerm, + haAcceptVersion = acceptableVersion, + haQueryVersion = queryVersion, + haTimeLimits = noTimeLimitsHandshake + + } (simpleSingletonVersions (maxBound :: NodeToNodeVersion) (NodeToNodeVersionData { @@ -176,8 +179,7 @@ demo chain0 updates = withIOManager $ \iocp -> do peerSharing = PeerSharingDisabled, query = False }) (SomeResponderApplication responderApp)) - nullErrorPolicies - $ \realProducerAddress _ -> do + $ \producerAddress' _ -> do withAsync (connectToNode (socketSnocket iocp) @@ -199,7 +201,7 @@ demo chain0 updates = withIOManager $ \iocp -> do query = False }) initiatorApp) (Just consumerAddress) - realProducerAddress) + producerAddress') $ \ _connAsync -> do void $ forkIO $ sequence_ [ do diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index f7909d1fb51..7849d4034bd 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -67,8 +67,6 @@ library Ouroboros.Network.DeltaQ Ouroboros.Network.Diffusion Ouroboros.Network.Diffusion.Configuration - Ouroboros.Network.Diffusion.NonP2P - Ouroboros.Network.Diffusion.P2P Ouroboros.Network.Diffusion.Policies Ouroboros.Network.ExitPolicy Ouroboros.Network.KeepAlive @@ -90,13 +88,12 @@ library Ouroboros.Network.PeerSelection.State.LocalRootPeers Ouroboros.Network.PeerSelection.Types Ouroboros.Network.PeerSharing - Ouroboros.Network.Tracers Ouroboros.Network.TxSubmission.Inbound Ouroboros.Network.TxSubmission.Mempool.Reader Ouroboros.Network.TxSubmission.Outbound other-modules: - Ouroboros.Network.Diffusion.Common + Ouroboros.Network.Diffusion.Types Ouroboros.Network.Diffusion.Utils Ouroboros.Network.PeerSelection.Churn Ouroboros.Network.PeerSelection.Governor.ActivePeers @@ -201,7 +198,6 @@ library sim-tests-lib base >=4.14 && <4.21, bytestring, cardano-binary, - cardano-prelude, cardano-slotting, cborg, containers, @@ -262,7 +258,6 @@ library sim-tests-lib Test.Ouroboros.Network.PeerSelection.PeerMetric Test.Ouroboros.Network.PeerSelection.PublicRootPeers Test.Ouroboros.Network.PeerSelection.RootPeersDNS - Test.Ouroboros.Network.PeerState Test.Ouroboros.Network.Testnet Test.Ouroboros.Network.Testnet.Internal Test.Ouroboros.Network.Testnet.Node @@ -325,6 +320,7 @@ test-suite io-tests ouroboros-network, ouroboros-network-api, ouroboros-network-framework, + ouroboros-network-framework:testlib, ouroboros-network-mock, ouroboros-network-protocols, ouroboros-network-protocols:testlib, @@ -367,6 +363,7 @@ executable demo-chain-sync ouroboros-network, ouroboros-network-api, ouroboros-network-framework, + ouroboros-network-framework:testlib, ouroboros-network-mock, ouroboros-network-protocols, random, diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerState.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerState.hs deleted file mode 100644 index 96c4700cf78..00000000000 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerState.hs +++ /dev/null @@ -1,499 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module Test.Ouroboros.Network.PeerState (tests) where - - -import Control.Exception (ArithException (..), AsyncException (..), - NonTermination (..)) -import Data.Functor (void) -import Data.Map.Strict qualified as Map -import Data.Monoid (First (..)) -import Data.Set qualified as Set -import Text.Printf - -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadFork -import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime.SI -import Control.Tracer - -import Data.Semigroup.Action -import Ouroboros.Network.ErrorPolicy -import Ouroboros.Network.Server.ConnectionTable -import Ouroboros.Network.Snocket -import Ouroboros.Network.Subscription.Ip -import Ouroboros.Network.Subscription.PeerState -import Ouroboros.Network.Subscription.Worker - -import Test.QuickCheck hiding (Result) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.QuickCheck (testProperty) - -tests :: TestTree -tests = testGroup "Ouroboros.Network.Subscription.PeerState" - [ testProperty "SuspendDecision semigroup" (prop_SuspendDecisionSemigroup @Int) - , testProperty "Suspend semigroup action on PeerState (up to constructor)" - (prop_SuspendDecisionAction @IO) - , testProperty "worker error handling" prop_subscriptionWorker - ] - - --- --- Generators of 'SuspendDecision' and 'PeerState' --- - -newtype ArbSuspendDecision t = ArbSuspendDecision { - getArbSuspendDecision :: SuspendDecision t - } - deriving (Eq, Show) - -genSuspendDecision :: Gen t - -> Gen (SuspendDecision t) -genSuspendDecision gen = oneof - [ SuspendPeer <$> gen <*> gen - , SuspendConsumer <$> gen - , pure Throw - ] - -genDiffTime :: Gen DiffTime -genDiffTime = fromIntegral @Int <$> arbitrary - -instance Arbitrary t => Arbitrary (ArbSuspendDecision t) where - arbitrary = ArbSuspendDecision <$> genSuspendDecision arbitrary - --- | Subsemigroup formed by 'SuspendPeer' and 'SuspendDecision'. --- -newtype SuspendSubsemigroup t = SuspendSubsemigroup { - getSuspendSubsemigroup :: SuspendDecision t - } - deriving (Eq, Show) - -instance Arbitrary t => Arbitrary (SuspendSubsemigroup t) where - arbitrary = oneof - [ SuspendSubsemigroup <$> (SuspendPeer <$> arbitrary <*> arbitrary) - , SuspendSubsemigroup . SuspendConsumer <$> arbitrary - ] - -newtype ArbPeerState m = ArbPeerState { - getArbPeerState :: PeerState m - } - -instance ( Ord (ThreadId m) - , Show (ThreadId m) - , MonadAsync m - ) => Show (ArbPeerState m) where - show (ArbPeerState p) = "ArbPeerState " ++ show p - --- TODO: it only generates times, not ThreadId's. -instance Arbitrary (ArbPeerState m) where - arbitrary = oneof - [ pure $ ArbPeerState (HotPeer Set.empty Set.empty) - , ArbPeerState . SuspendedConsumer Set.empty . getArbTime <$> arbitrary - , ArbPeerState <$> (SuspendedPeer <$> (getArbTime <$> arbitrary) - <*> (getArbTime <$> arbitrary)) - , pure (ArbPeerState ColdPeer) - ] - --- --- Algebraic properties of 'SuspendDecision' and 'PeerState' --- - -prop_SuspendDecisionSemigroup - :: Ord t - => ArbSuspendDecision t - -> ArbSuspendDecision t - -> ArbSuspendDecision t - -> Bool -prop_SuspendDecisionSemigroup (ArbSuspendDecision a1) - (ArbSuspendDecision a2) - (ArbSuspendDecision a3) = - a1 <> (a2 <> a3) == (a1 <> a2) <> a3 - -prop_SuspendDecisionAction - :: forall m. - Eq (Async m ()) - => Blind (Maybe (ArbPeerState m)) - -> ArbSuspendDecision ArbTime - -> ArbSuspendDecision ArbTime - -> Bool -prop_SuspendDecisionAction - (Blind mps) - (ArbSuspendDecision a1) - (ArbSuspendDecision a2) = - mps' <| (sd1 <> sd2) == (mps' <| sd1 <| sd2) - where - sd1 = getArbTime <$> a1 - sd2 = getArbTime <$> a2 - mps' :: Maybe (PeerState m) - mps' = getArbPeerState <$> mps - --- | Like 'ArbPeerState' but does not generate 'HotPeer' with empty producer --- and consumer sets. --- -newtype ArbValidPeerState m = ArbValidPeerState (PeerState m) - --- TODO -instance Show (ArbValidPeerState t) where - show (ArbValidPeerState _) = "ArbValidPeerState" - -instance Arbitrary (ArbValidPeerState m) where - arbitrary = oneof - [ ArbValidPeerState . SuspendedConsumer Set.empty . getArbTime <$> arbitrary - , ArbValidPeerState <$> (SuspendedPeer <$> (getArbTime <$> arbitrary) - <*> (getArbTime <$> arbitrary)) - , pure (ArbValidPeerState ColdPeer) - ] - -data ArbException where - ArbException - :: Exception err - => err - -> ArbException - -instance Show ArbException where - show (ArbException err) = "ArbException " ++ show err - -data TestException1 = TestException1 - deriving Show - -instance Exception TestException1 - -data TestException2 = TestException2 - deriving Show - -instance Exception TestException2 - -instance Arbitrary ArbException where - arbitrary = oneof - [ pure (ArbException TestException1) - , pure (ArbException TestException2) - -- AsyncException - -- , pure (ArbException StackOverflow) - -- , pure (ArbException HeapOverflow) - -- NonTermination - -- , pure (ArbException NonTermination) - ] - -data ArbErrorPolicies = ArbErrorPolicies [ErrorPolicy] -- application error policy - [ErrorPolicy] -- connection error policy - deriving Show - - -genErrorPolicy :: Gen (SuspendDecision DiffTime) - -> Gen (ErrorPolicy) -genErrorPolicy genCmd = oneof - [ (\cmd -> ErrorPolicy (\(_e :: ArithException) -> Just cmd)) <$> genCmd, - (\cmd -> ErrorPolicy (\(_e :: AsyncException) -> Just cmd)) <$> genCmd, - (\cmd -> ErrorPolicy (\(_e :: NonTermination) -> Just cmd)) <$> genCmd - ] - -instance Arbitrary ArbErrorPolicies where - arbitrary = ArbErrorPolicies <$> listOf genPolicy <*> listOf genPolicy - where - genPolicy = genErrorPolicy (genSuspendDecision genDiffTime) - - shrink (ArbErrorPolicies aps cps) = - let aps' = shrinkList (const []) aps - cps' = shrinkList (const []) cps in - map (\(a,c) -> ArbErrorPolicies a c) $ zip aps' cps' - -data Sock addr = Sock { - remoteAddr :: addr - , localAddr :: addr - } - -data SnocketType where - - -- socket which allocates and connects with out an error, any error can - -- only come from an application - WorkingSnocket :: SnocketType - - -- socket which errors when allocating a socket - AllocateError :: forall e. Exception e - => e - -> SnocketType - - -- socket which errors when attempting a connection - ConnectError :: forall e. Exception e - => e - -> SnocketType - -instance Show SnocketType where - show (AllocateError e) = "AllocateError " ++show e - show (ConnectError e) = "ConnectError " ++show e - show WorkingSnocket = "WorkingSnocket" - -instance Arbitrary SnocketType where - arbitrary = oneof - -- we are not generating 'AllocateErrors', they will not kill the worker, - -- but only the connection thread. - [ (\(ArbException e) -> ConnectError e) <$> arbitrary - , pure WorkingSnocket - ] - --- | 'addrFamily', 'accept' is not needed to run the test suite. --- -mkSnocket :: MonadThrow m - => SnocketType - -> addr - -> addr - -> Snocket m (Sock addr) addr -mkSnocket (AllocateError e) _localAddr _remoteAddr = Snocket { - getLocalAddr = \Sock{localAddr} -> pure localAddr - , getRemoteAddr = \Sock{remoteAddr = addr} -> pure addr - , addrFamily = error "not supported" - , open = \_ -> throwIO e - , openToConnect = \_ -> throwIO e - , connect = \_ _ -> pure () - , bind = \_ _ -> pure () - , listen = \_ -> pure () - , accept = \_ -> error "not supported" - , close = \_ -> pure () - } -mkSnocket (ConnectError e) localAddr remoteAddr = Snocket { - getLocalAddr = \Sock{localAddr = addr} -> pure addr - , getRemoteAddr = \Sock{remoteAddr = addr} -> pure addr - , addrFamily = error "not supported" - , open = \_ -> pure Sock {remoteAddr, localAddr} - , openToConnect = \_ -> pure Sock {remoteAddr, localAddr} - , connect = \_ _ -> throwIO e - , accept = \_ -> error "not supported" - , bind = \_ _ -> pure () - , listen = \_ -> pure () - , close = \_ -> pure () - } -mkSnocket WorkingSnocket localAddr remoteAddr = Snocket { - getLocalAddr = \Sock{localAddr = addr} -> pure addr - , getRemoteAddr = \Sock{remoteAddr = addr} -> pure addr - , addrFamily = error "not supported" - , open = \_ -> pure Sock {remoteAddr, localAddr} - , openToConnect = \_ -> pure Sock {remoteAddr, localAddr} - , connect = \_ _ -> pure () - , bind = \_ _ -> pure () - , listen = \_ -> pure () - , accept = \_ -> error "not supported" - , close = \_ -> pure () - } - -data ArbApp addr = ArbApp (Maybe ArbException) (Sock addr -> IO ()) - -instance Arbitrary (ArbApp addr) where - arbitrary = oneof - [ (\a@(ArbException e) -> ArbApp (Just a) (\_ -> throwIO e)) <$> arbitrary - , pure $ ArbApp Nothing (\_ -> pure ()) - ] - -newtype ArbDiffTime = ArbDiffTime { - getArbDiffTime :: DiffTime - } - deriving Show - deriving Eq - deriving Ord - deriving Num via DiffTime - deriving Fractional via DiffTime - deriving Real via DiffTime - deriving RealFrac via DiffTime - -instance Arbitrary ArbDiffTime where - arbitrary = ArbDiffTime . fromIntegral @Int <$> arbitrary - -instance CoArbitrary ArbDiffTime where - coarbitrary (ArbDiffTime t) = coarbitrary (toRational t) - -instance Function ArbDiffTime where - function = functionRealFrac - -newtype ArbTime = ArbTime { getArbTime :: Time } - deriving Show - deriving Eq - deriving Ord - deriving Num via DiffTime - deriving Fractional via DiffTime - deriving Real via DiffTime - deriving RealFrac via DiffTime - -instance Arbitrary ArbTime where - arbitrary = ArbTime . Time . getArbDiffTime <$> arbitrary - -instance CoArbitrary ArbTime where - coarbitrary (ArbTime (Time t)) = coarbitrary (toRational t) - -instance Function ArbTime where - function = functionRealFrac - -prop_subscriptionWorker - :: SnocketType - -> Int -- local address - -> Int -- remote address - -> ArbValidPeerState IO - -> ArbErrorPolicies - -> (Blind (ArbApp Int)) - -> Property -prop_subscriptionWorker - sockType localAddr remoteAddr (ArbValidPeerState ps) - (ArbErrorPolicies appErrPolicies conErrPolicies) - (Blind (ArbApp merr app)) - = - tabulate "peer states & app errors" [printf "%-20s %s" (peerStateType ps) (exceptionType merr)] $ - ioProperty $ do - doneVar :: StrictTMVar IO () <- newEmptyTMVarIO - tbl <- newConnectionTable - peerStatesVar <- newPeerStatesVar - worker nullTracer - nullTracer - tbl - peerStatesVar - (mkSnocket sockType localAddr remoteAddr) - mempty - WorkerCallbacks { - wcSocketStateChangeTx = \ss s -> do - s' <- socketStateChangeTx ss s - case ss of - CreatedSocket{} -> pure s' - ClosedSocket{} -> tryPutTMVar doneVar () >> pure s', - wcCompleteApplicationTx = completeTx, - wcMainTx = main doneVar - } - WorkerParams { - wpLocalAddresses = LocalAddresses { - laIpv4 = Just localAddr, - laIpv6 = Just localAddr, - laUnix = Nothing - }, - wpSelectAddress = \_ LocalAddresses {laIpv4, laIpv6} -> getFirst (First laIpv4 <> First laIpv6), - wpConnectionAttemptDelay = const Nothing, - wpSubscriptionTarget = - pure $ ipSubscriptionTarget nullTracer peerStatesVar [remoteAddr], - wpValency = 1 - } - (\sock -> app sock - `finally` - (void $ atomically $ tryPutTMVar doneVar ())) - where - completeTx = completeApplicationTx - (ErrorPolicies - appErrPolicies - conErrPolicies) - - main :: StrictTMVar IO () -> Main IO (PeerStates IO Int) Bool - main doneVar s = do - done <- maybe False (const True) <$> tryReadTMVar doneVar - let r = case sockType of - WorkingSnocket -> case merr of - -- TODO: we don't have access to the time when the transition was - -- evaluated. - Nothing -> True - Just (ArbException e) -> transitionSpec remoteAddr ps - (evalErrorPolicies e appErrPolicies) - s - AllocateError _ -> True - ConnectError e -> transitionSpec remoteAddr ps - (evalErrorPolicies e conErrPolicies) - s - if done - then pure r - else if r then retry else pure r - - -- - -- tabulating QuickCheck's cases - -- - - peerStateType HotPeer{} = "HotPeer" - peerStateType SuspendedConsumer{} = "SuspendedConsumer" - peerStateType SuspendedPeer{} = "SuspendedPeer" - peerStateType ColdPeer{} = "ColdPeer" - - exceptionType Nothing = "no-exception" - exceptionType (Just _) = "with-exception" - --- transition spec from a given state to a target states -transitionSpec :: Ord addr - => addr - -> PeerState IO - -> Maybe (SuspendDecision DiffTime) - -> PeerStates IO addr - -> Bool - -transitionSpec _addr _ps0 Nothing ThrowException{} = False - -transitionSpec addr ps0 Nothing (PeerStates peerStates) = - case Map.lookup addr peerStates of - Nothing -> True - Just ps1 -> case (ps0, ps1) of - (ColdPeer, ColdPeer) - -> True - (ColdPeer, HotPeer producers consumers) - -> not (Set.null producers) || not (Set.null consumers) - (ColdPeer, _) - -> False - - -- this transition can happen only if 'producers' are empty - (SuspendedConsumer producers _consT, ColdPeer) - | Set.null producers - -> True - | otherwise - -> False - (SuspendedConsumer _ consT, SuspendedConsumer _ consT') - -> consT == consT' - (SuspendedConsumer _ _consT, HotPeer _ consumers) - -> not $ Set.null consumers - (SuspendedConsumer _ consT, SuspendedPeer _ consT') - -> consT' >= consT - - (SuspendedPeer{}, HotPeer producers consumers) - | Set.null producers && Set.null consumers - -> False - | otherwise - -> True - (SuspendedPeer{}, _) - -> True - - (HotPeer producers consumers, ColdPeer) - | Set.null consumers && Set.null producers - -> True - | otherwise - -> False - (HotPeer{}, HotPeer producers consumers) - | Set.null producers && Set.null consumers - -> False - | otherwise - -> True - (HotPeer{}, SuspendedConsumer{}) - -> True - (HotPeer{}, SuspendedPeer{}) - -> True - -transitionSpec _addr _ps0 (Just Throw) ThrowException{} = True -transitionSpec _addr _ps0 (Just _) ThrowException{} = False - -transitionSpec addr ps0 (Just cmd) (PeerStates peerStates) = - case Map.lookup addr peerStates of - Nothing -> True - Just ps1 -> case (cmd, ps1) of - (SuspendPeer{}, SuspendedPeer{}) - -> True - (SuspendPeer{}, _) - -> False - (SuspendConsumer{}, SuspendedConsumer producers _) - -> getProducers ps0 == producers - (SuspendConsumer{}, SuspendedPeer{}) - -> True - (SuspendConsumer{}, _) - -> False - (Throw, _) - -> True - where - getProducers :: PeerState IO -> Set.Set (Async IO ()) - getProducers (HotPeer producers _) = producers - getProducers (SuspendedConsumer producers _) = producers - getProducers _ = Set.empty diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs index 9aad3e425d6..1d3456ad7f9 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs @@ -78,7 +78,7 @@ import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers import Ouroboros.Network.PeerSelection.Types import Ouroboros.Network.PeerSharing (PeerSharingResult (..)) -import Ouroboros.Network.Server2 qualified as Server +import Ouroboros.Network.Server qualified as Server import Simulation.Network.Snocket (BearerInfo (..)) @@ -3075,7 +3075,7 @@ prop_diffusion_target_active_local_above ioSimTrace traceNumber = -- | A variant of ouroboros-network-framework --- 'Test.Ouroboros.Network.Server2.prop_connection_manager_valid_transitions' +-- 'Test.Ouroboros.Network.Server.prop_connection_manager_valid_transitions' -- but for running on Diffusion. This means it has to have in consideration -- that the logs for all nodes running will all appear in the trace and the test -- property should only be valid while a given node is up and running. @@ -3163,7 +3163,7 @@ prop_diffusion_cm_valid_transitions ioSimTrace traceNumber = -- | A variant of ouroboros-network-framework --- 'Test.Ouroboros.Network.Server2.prop_connection_manager_valid_transition_order' +-- 'Test.Ouroboros.Network.Server.prop_connection_manager_valid_transition_order' -- but for running on Diffusion. This means it has to have in consideration the -- the logs for all nodes running will all appear in the trace and the test -- property should only be valid while a given node is up and running. @@ -3224,7 +3224,7 @@ prop_diffusion_cm_valid_transition_order_iosim_por ioSimTrace traceNumber = . groupConns id abstractStateIsFinalTransitionTVarTracing -- | A variant of ouroboros-network-framework --- 'Test.Ouroboros.Network.Server2.prop_connection_manager_valid_transition_order' +-- 'Test.Ouroboros.Network.Server.prop_connection_manager_valid_transition_order' -- but for running on Diffusion. This means it has to have in consideration the -- the logs for all nodes running will all appear in the trace and the test -- property should only be valid while a given node is up and running. @@ -4059,7 +4059,7 @@ prop_splitWith f as = foldr (++) [] (splitWith f as) === as -- | A variant of ouroboros-network-framework --- 'Test.Ouroboros.Network.Server2.prop_inbound_governor_valid_transitions' +-- 'Test.Ouroboros.Network.Server.prop_inbound_governor_valid_transitions' -- but for running on Diffusion. This means it has to have in consideration the -- the logs for all nodes running will all appear in the trace and the test -- property should only be valid while a given node is up and running. @@ -4117,7 +4117,7 @@ prop_diffusion_ig_valid_transitions ioSimTrace traceNumber = $ remoteTransitionTraceEvents -- | A variant of ouroboros-network-framework --- 'Test.Ouroboros.Network.Server2.prop_inbound_governor_valid_transition_order' +-- 'Test.Ouroboros.Network.Server.prop_inbound_governor_valid_transition_order' -- but for running on Diffusion. This means it has to have in consideration the -- the logs for all nodes running will all appear in the trace and the test -- property should only be valid while a given node is up and running. @@ -4170,7 +4170,7 @@ prop_diffusion_ig_valid_transition_order ioSimTrace traceNumber = $ remoteTransitionTraceEvents -- | A variant of ouroboros-network-framework --- 'Test.Ouroboros.Network.Server2.prop_timeouts_enforced' +-- 'Test.Ouroboros.Network.Server.prop_timeouts_enforced' -- but for running on Diffusion. This means it has to have in consideration the -- the logs for all nodes running will all appear in the trace and the test -- property should only be valid while a given node is up and running. diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Internal.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Internal.hs index 0f5b9bc791c..9320e02d368 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Internal.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Internal.hs @@ -77,7 +77,7 @@ import Ouroboros.Network.ConnectionManager.Core qualified as CM import Ouroboros.Network.ConnectionManager.State qualified as CM import Ouroboros.Network.ConnectionManager.Types (AbstractTransitionTrace) import Ouroboros.Network.ConsensusMode -import Ouroboros.Network.Diffusion.P2P qualified as Diff.P2P +import Ouroboros.Network.Diffusion qualified as Diff import Ouroboros.Network.Driver.Limits (ProtocolSizeLimits (..), ProtocolTimeLimits (..)) import Ouroboros.Network.InboundGovernor qualified as IG @@ -100,8 +100,8 @@ import Ouroboros.Network.Protocol.Handshake.Version (Accept (Accept)) import Ouroboros.Network.Protocol.KeepAlive.Codec (byteLimitsKeepAlive, timeLimitsKeepAlive) import Ouroboros.Network.Protocol.Limits (shortWait, smallByteLimit) +import Ouroboros.Network.Server qualified as Server import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) -import Ouroboros.Network.Server2 qualified as Server import Ouroboros.Network.Snocket (Snocket, TestAddress (..)) import Ouroboros.Network.Block (BlockNo) @@ -1218,7 +1218,7 @@ diffusionSimulation limitsAndTimeouts interfaces arguments - (tracersExtra addr) + (tracers addr) ( contramap (DiffusionFetchTrace . (\(TraceLabelPeer _ a) -> a)) . tracerWithName addr . tracerWithTime @@ -1249,78 +1249,78 @@ diffusionSimulation . tracerWithTime $ nodeTracer - tracersExtra + tracers :: NtNAddr - -> Diff.P2P.TracersExtra NtNAddr NtNVersion NtNVersionData - NtCAddr NtCVersion NtCVersionData - SomeException m - tracersExtra ntnAddr = - Diff.P2P.TracersExtra { - Diff.P2P.dtTraceLocalRootPeersTracer = contramap DiffusionLocalRootPeerTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer - , Diff.P2P.dtTracePublicRootPeersTracer = contramap - DiffusionPublicRootPeerTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer - , Diff.P2P.dtTraceLedgerPeersTracer = contramap - DiffusionLedgerPeersTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer - , Diff.P2P.dtTracePeerSelectionTracer = contramap - DiffusionPeerSelectionTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer - , Diff.P2P.dtDebugPeerSelectionInitiatorTracer = contramap DiffusionDebugPeerSelectionTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer - , Diff.P2P.dtDebugPeerSelectionInitiatorResponderTracer + -> Diff.Tracers NtNAddr NtNVersion NtNVersionData + NtCAddr NtCVersion NtCVersionData + SomeException m + tracers ntnAddr = + Diff.nullTracers { + Diff.dtTraceLocalRootPeersTracer = contramap DiffusionLocalRootPeerTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer + , Diff.dtTracePublicRootPeersTracer = contramap + DiffusionPublicRootPeerTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer + , Diff.dtTraceLedgerPeersTracer = contramap + DiffusionLedgerPeersTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer + , Diff.dtTracePeerSelectionTracer = contramap + DiffusionPeerSelectionTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer + , Diff.dtDebugPeerSelectionInitiatorTracer = contramap DiffusionDebugPeerSelectionTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer + , Diff.dtDebugPeerSelectionInitiatorResponderTracer = contramap DiffusionDebugPeerSelectionTrace . tracerWithName ntnAddr . tracerWithTime $ nodeTracer - , Diff.P2P.dtTracePeerSelectionCounters = nullTracer - , Diff.P2P.dtTraceChurnCounters = nullTracer - , Diff.P2P.dtPeerSelectionActionsTracer = contramap - DiffusionPeerSelectionActionsTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer - , Diff.P2P.dtConnectionManagerTracer = contramap - DiffusionConnectionManagerTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer - , Diff.P2P.dtConnectionManagerTransitionTracer = contramap - DiffusionConnectionManagerTransitionTrace - . tracerWithName ntnAddr - . tracerWithTime - -- note: we have two ways getting transition trace: + , Diff.dtTracePeerSelectionCounters = nullTracer + , Diff.dtTraceChurnCounters = nullTracer + , Diff.dtPeerSelectionActionsTracer = contramap + DiffusionPeerSelectionActionsTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer + , Diff.dtConnectionManagerTracer = contramap + DiffusionConnectionManagerTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer + , -- note: we have two ways getting transition trace: -- * through `traceTVar` installed in `newMutableConnState` -- * the `dtConnectionManagerTransitionTracer` - $ nodeTracer - , Diff.P2P.dtServerTracer = contramap DiffusionServerTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer - , Diff.P2P.dtInboundGovernorTracer = contramap - DiffusionInboundGovernorTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer - , Diff.P2P.dtInboundGovernorTransitionTracer = contramap - DiffusionInboundGovernorTransitionTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer - , Diff.P2P.dtLocalConnectionManagerTracer = nullTracer - , Diff.P2P.dtLocalServerTracer = nullTracer - , Diff.P2P.dtLocalInboundGovernorTracer = nullTracer + Diff.dtConnectionManagerTransitionTracer = contramap + DiffusionConnectionManagerTransitionTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer + , Diff.dtServerTracer = contramap DiffusionServerTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer + , Diff.dtInboundGovernorTracer = contramap + DiffusionInboundGovernorTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer + , Diff.dtInboundGovernorTransitionTracer = contramap + DiffusionInboundGovernorTransitionTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer + , Diff.dtLocalConnectionManagerTracer = nullTracer + , Diff.dtLocalServerTracer = nullTracer + , Diff.dtLocalInboundGovernorTracer = nullTracer } diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node.hs index ba823f49749..f9952f73176 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node.hs @@ -24,8 +24,8 @@ module Test.Ouroboros.Network.Testnet.Node , DiffusionMode (..) , PeerAdvertise (..) , PeerSelectionTargets (..) - -- * configuration constants - , config_REPROMOTE_DELAY + -- * configuration + , Node.config_REPROMOTE_DELAY ) where import Control.Applicative (Alternative) @@ -71,21 +71,17 @@ import Ouroboros.Network.ConnectionManager.State qualified as CM import Ouroboros.Network.ConnectionManager.Types (DataFlow (..)) import Ouroboros.Network.ConsensusMode import Ouroboros.Network.Diffusion qualified as Diff -import Ouroboros.Network.Diffusion.P2P qualified as Diff.P2P -import Ouroboros.Network.ExitPolicy (RepromoteDelay (..)) import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) import Ouroboros.Network.PeerSelection.Governor (ConsensusModePeerTargets, PeerSelectionTargets (..), PublicPeerSelectionState (..)) -import Ouroboros.Network.PeerSelection.PeerMetric - (PeerMetricsConfiguration (..), newPeerMetric) +import Ouroboros.Network.PeerSelection.PeerMetric (PeerMetrics, + PeerMetricsConfiguration (..), newPeerMetric) import Ouroboros.Network.Protocol.Handshake (HandshakeArguments (..)) import Ouroboros.Network.Protocol.Handshake.Codec (VersionDataCodec (..), noTimeLimitsHandshake, timeLimitsHandshake) import Ouroboros.Network.Protocol.Handshake.Unversioned (unversionedHandshakeCodec, unversionedProtocolDataCodec) import Ouroboros.Network.Protocol.Handshake.Version (Accept (Accept)) -import Ouroboros.Network.RethrowPolicy (ErrorCommand (ShutdownNode), - ioErrorRethrowPolicy, mkRethrowPolicy, muxErrorRethrowPolicy) import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) import Ouroboros.Network.Snocket (MakeBearer, Snocket, TestAddress (..), invalidFileDescriptor) @@ -189,12 +185,12 @@ run :: forall resolver m. -> Node.LimitsAndTimeouts BlockHeader Block -> Interfaces m -> Arguments m - -> Diff.P2P.TracersExtra NtNAddr NtNVersion NtNVersionData - NtCAddr NtCVersion NtCVersionData - ResolverException m + -> Diff.Tracers NtNAddr NtNVersion NtNVersionData + NtCAddr NtCVersion NtCVersionData + ResolverException m -> Tracer m (TraceLabelPeer NtNAddr (TraceFetchClientState BlockHeader)) -> m Void -run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = +run blockGeneratorArgs limits ni na tracers tracerBlockFetch = Node.withNodeKernelThread blockGeneratorArgs $ \ nodeKernel nodeKernelThread -> do dnsTimeoutScriptVar <- newTVarIO (aDNSTimeoutScript na) @@ -203,17 +199,17 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = peerMetrics <- newPeerMetric PeerMetricsConfiguration { maxEntriesToTrack = 180 } let -- diffusion interfaces - interfaces :: Diff.P2P.Interfaces (NtNFD m) NtNAddr NtNVersion NtNVersionData - (NtCFD m) NtCAddr NtCVersion NtCVersionData - resolver ResolverException - m - interfaces = Diff.P2P.Interfaces - { Diff.P2P.diNtnSnocket = iNtnSnocket ni - , Diff.P2P.diNtnBearer = iNtnBearer ni - , Diff.P2P.diNtnConfigureSocket = \_ _ -> return () - , Diff.P2P.diNtnConfigureSystemdSocket + interfaces :: Diff.Interfaces (NtNFD m) NtNAddr NtNVersion NtNVersionData + (NtCFD m) NtCAddr NtCVersion NtCVersionData + resolver ResolverException + m + interfaces = Diff.Interfaces + { Diff.diNtnSnocket = iNtnSnocket ni + , Diff.diNtnBearer = iNtnBearer ni + , Diff.diNtnConfigureSocket = \_ _ -> return () + , Diff.diNtnConfigureSystemdSocket = \_ _ -> return () - , Diff.P2P.diNtnHandshakeArguments = + , Diff.diNtnHandshakeArguments = HandshakeArguments { haHandshakeTracer = nullTracer , haHandshakeCodec = unversionedHandshakeCodec @@ -222,16 +218,16 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = , haQueryVersion = const False , haTimeLimits = timeLimitsHandshake } - , Diff.P2P.diNtnAddressType = ntnAddressType - , Diff.P2P.diNtnDataFlow = \NtNVersionData { ntnDiffusionMode } -> + , Diff.diNtnAddressType = ntnAddressType + , Diff.diNtnDataFlow = \NtNVersionData { ntnDiffusionMode } -> case ntnDiffusionMode of InitiatorOnlyDiffusionMode -> Unidirectional InitiatorAndResponderDiffusionMode -> Duplex - , Diff.P2P.diNtnPeerSharing = ntnPeerSharing - , Diff.P2P.diNtnToPeerAddr = \a b -> TestAddress (Node.IPAddr a b) - , Diff.P2P.diNtcSnocket = iNtcSnocket ni - , Diff.P2P.diNtcBearer = iNtcBearer ni - , Diff.P2P.diNtcHandshakeArguments = + , Diff.diNtnPeerSharing = ntnPeerSharing + , Diff.diNtnToPeerAddr = \a b -> TestAddress (Node.IPAddr a b) + , Diff.diNtcSnocket = iNtcSnocket ni + , Diff.diNtcBearer = iNtcBearer ni + , Diff.diNtcHandshakeArguments = HandshakeArguments { haHandshakeTracer = nullTracer , haHandshakeCodec = unversionedHandshakeCodec @@ -240,45 +236,25 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = , haQueryVersion = const False , haTimeLimits = noTimeLimitsHandshake } - , Diff.P2P.diNtcGetFileDescriptor = \_ -> pure invalidFileDescriptor - , Diff.P2P.diRng = diffStgGen - , Diff.P2P.diInstallSigUSR1Handler = \_ _ _ -> pure () - , Diff.P2P.diDnsActions = const (mockDNSActions + , Diff.diNtcGetFileDescriptor = \_ -> pure invalidFileDescriptor + , Diff.diRng = diffStgGen + , Diff.diInstallSigUSR1Handler = \_ _ _ -> pure () + , Diff.diDnsActions = const (mockDNSActions (iDomainMap ni) dnsTimeoutScriptVar dnsLookupDelayScriptVar) - , Diff.P2P.diUpdateVersionData = \versionData diffusionMode -> - versionData { ntnDiffusionMode = diffusionMode } - , Diff.P2P.diConnStateIdSupply = iConnStateIdSupply ni + , Diff.diUpdateVersionData = \versionData diffusionMode -> + versionData { ntnDiffusionMode = diffusionMode } + , Diff.diConnStateIdSupply = iConnStateIdSupply ni } - appsExtra :: Diff.P2P.ApplicationsExtra NtNAddr m () - appsExtra = Diff.P2P.ApplicationsExtra - { -- TODO: simulation errors should be critical - Diff.P2P.daRethrowPolicy = - muxErrorRethrowPolicy - <> ioErrorRethrowPolicy - - -- we are not using local connections, so we can make all the - -- errors fatal. - , Diff.P2P.daLocalRethrowPolicy = - mkRethrowPolicy - (\ _ (_ :: SomeException) -> ShutdownNode) - , Diff.P2P.daPeerMetrics = peerMetrics - -- fetch mode is not used (no block-fetch mini-protocol) - , Diff.P2P.daBlockFetchMode = pure $ PraosFetchMode FetchModeDeadline - , Diff.P2P.daReturnPolicy = \_ -> config_REPROMOTE_DELAY - , Diff.P2P.daPeerSharingRegistry = nkPeerSharingRegistry nodeKernel - } - - let apps = Node.applications (aDebugTracer na) nodeKernel Node.cborCodecs limits appArgs blockHeader + let apps = Node.applications (aDebugTracer na) nodeKernel Node.cborCodecs limits (appArgs peerMetrics) blockHeader withAsync - (Diff.P2P.runM interfaces - Diff.nullTracers - tracersExtra - (mkArgs (nkPublicPeerSelectionVar nodeKernel)) - (mkArgsExtra useBootstrapPeersScriptVar) apps appsExtra) + (Diff.runM interfaces + tracers + (mkArgs (nkPublicPeerSelectionVar nodeKernel) useBootstrapPeersScriptVar) + apps) $ \ diffusionThread -> withAsync (blockFetch nodeKernel) $ \blockFetchLogicThread -> wait diffusionThread @@ -386,8 +362,9 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = decodeData _ _ = Left (Text.pack "unversionedDataCodec: unexpected term") mkArgs :: StrictTVar m (PublicPeerSelectionState NtNAddr) + -> StrictTVar m (Script UseBootstrapPeers) -> Diff.Arguments m (NtNFD m) NtNAddr (NtCFD m) NtCAddr - mkArgs daPublicPeerSelectionVar = Diff.Arguments + mkArgs daPublicPeerSelectionVar ubpVar = Diff.Arguments { Diff.daIPv4Address = Right <$> (ntnToIPv4 . aIPAddress) na , Diff.daIPv6Address = Right <$> (ntnToIPv6 . aIPAddress) na , Diff.daLocalAddress = Nothing @@ -395,29 +372,24 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = = aAcceptedLimits na , Diff.daMode = aDiffusionMode na , Diff.daPublicPeerSelectionVar - } - - mkArgsExtra :: StrictTVar m (Script UseBootstrapPeers) - -> Diff.P2P.ArgumentsExtra m - mkArgsExtra ubpVar = Diff.P2P.ArgumentsExtra - { Diff.P2P.daPeerTargets = aPeerTargets na - , Diff.P2P.daReadLocalRootPeers = aReadLocalRootPeers na - , Diff.P2P.daReadPublicRootPeers = aReadPublicRootPeers na - , Diff.P2P.daReadUseBootstrapPeers = stepScriptSTM' ubpVar - , Diff.P2P.daOwnPeerSharing = aOwnPeerSharing na - , Diff.P2P.daReadUseLedgerPeers = aReadUseLedgerPeers na - , Diff.P2P.daProtocolIdleTimeout = aProtocolIdleTimeout na - , Diff.P2P.daTimeWaitTimeout = aTimeWaitTimeout na - , Diff.P2P.daDeadlineChurnInterval = 3300 - , Diff.P2P.daBulkChurnInterval = 300 - , Diff.P2P.daReadLedgerPeerSnapshot = pure Nothing -- ^ tested independently - , Diff.P2P.daConsensusMode = aConsensusMode na - , Diff.P2P.daMinBigLedgerPeersForTrustedState + , Diff.daPeerTargets = aPeerTargets na + , Diff.daReadLocalRootPeers = aReadLocalRootPeers na + , Diff.daReadPublicRootPeers = aReadPublicRootPeers na + , Diff.daReadUseBootstrapPeers = stepScriptSTM' ubpVar + , Diff.daOwnPeerSharing = aOwnPeerSharing na + , Diff.daReadUseLedgerPeers = aReadUseLedgerPeers na + , Diff.daProtocolIdleTimeout = aProtocolIdleTimeout na + , Diff.daTimeWaitTimeout = aTimeWaitTimeout na + , Diff.daDeadlineChurnInterval = 3300 + , Diff.daBulkChurnInterval = 300 + , Diff.daReadLedgerPeerSnapshot = pure Nothing -- ^ tested independently + , Diff.daConsensusMode = aConsensusMode na + , Diff.daMinBigLedgerPeersForTrustedState = MinBigLedgerPeersForTrustedState 0 -- ^ todo: fix } - appArgs :: Node.AppArgs BlockHeader Block m - appArgs = Node.AppArgs + appArgs :: PeerMetrics m NtNAddr -> Node.AppArgs BlockHeader Block m + appArgs peerMetrics = Node.AppArgs { Node.aaLedgerPeersConsensusInterface = iLedgerPeersConsensusInterface ni , Node.aaKeepAliveStdGen = keepAliveStdGen @@ -429,6 +401,7 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = , Node.aaOwnPeerSharing = aOwnPeerSharing na , Node.aaUpdateOutboundConnectionsState = iUpdateOutboundConnectionsState ni + , Node.aaPeerMetrics = peerMetrics } --- Utils @@ -442,10 +415,3 @@ ntnToIPv6 :: NtNAddr -> Maybe NtNAddr ntnToIPv6 ntnAddr@(TestAddress (Node.EphemeralIPv6Addr _)) = Just ntnAddr ntnToIPv6 ntnAddr@(TestAddress (Node.IPAddr (IPv6 _) _)) = Just ntnAddr ntnToIPv6 (TestAddress _) = Nothing - --- --- Constants --- - -config_REPROMOTE_DELAY :: RepromoteDelay -config_REPROMOTE_DELAY = 10 diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node/MiniProtocols.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node/MiniProtocols.hs index fb57179fda4..e35c570e0b3 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node/MiniProtocols.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node/MiniProtocols.hs @@ -15,6 +15,8 @@ module Test.Ouroboros.Network.Testnet.Node.MiniProtocols , LimitsAndTimeouts (..) , AppArgs (..) , applications + -- * configuration constants + , config_REPROMOTE_DELAY ) where import Control.Applicative (Alternative) @@ -71,11 +73,15 @@ import Ouroboros.Network.Context import Ouroboros.Network.ControlMessage (ControlMessage (..)) import Ouroboros.Network.Diffusion qualified as Diff (Applications (..)) import Ouroboros.Network.Driver.Limits +import Ouroboros.Network.ExitPolicy (RepromoteDelay (..)) import Ouroboros.Network.KeepAlive import Ouroboros.Network.Mock.Chain qualified as Chain import Ouroboros.Network.Mock.ProducerState import Ouroboros.Network.Mux import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) +import Ouroboros.Network.PeerSelection.PeerMetric (PeerMetrics) +import Ouroboros.Network.RethrowPolicy (ErrorCommand (ShutdownNode), + ioErrorRethrowPolicy, mkRethrowPolicy, muxErrorRethrowPolicy) import Ouroboros.Network.Util.ShowProxy import Ouroboros.Network.Mock.ConcreteBlock @@ -210,6 +216,8 @@ data AppArgs header block m = AppArgs :: PSTypes.PeerSharing , aaUpdateOutboundConnectionsState :: OutboundConnectionsState -> STM m () + , aaPeerMetrics + :: PeerMetrics m NtNAddr } @@ -259,6 +267,7 @@ applications debugTracer nodeKernel , aaChainSyncEarlyExit , aaOwnPeerSharing , aaUpdateOutboundConnectionsState + , aaPeerMetrics } toHeader = Diff.Applications @@ -278,6 +287,21 @@ applications debugTracer nodeKernel aaLedgerPeersConsensusInterface , Diff.daUpdateOutboundConnectionsState = aaUpdateOutboundConnectionsState + + , Diff.daRethrowPolicy = + muxErrorRethrowPolicy + <> ioErrorRethrowPolicy + + -- we are not using local connections, so we can make all the + -- errors fatal. + , Diff.daLocalRethrowPolicy = + mkRethrowPolicy + (\ _ (_ :: SomeException) -> ShutdownNode) + , Diff.daPeerMetrics = aaPeerMetrics + -- fetch mode is not used (no block-fetch mini-protocol) + , Diff.daBlockFetchMode = pure (PraosFetchMode FetchModeDeadline) + , Diff.daReturnPolicy = \_ -> config_REPROMOTE_DELAY + , Diff.daPeerSharingRegistry = nkPeerSharingRegistry nodeKernel } where initiatorApp @@ -608,3 +632,10 @@ applications debugTracer nodeKernel instance ShowProxy PingPong where showProxy Proxy = "PingPong" + +-- +-- Constants +-- + +config_REPROMOTE_DELAY :: RepromoteDelay +config_REPROMOTE_DELAY = 10 diff --git a/ouroboros-network/sim-tests/Main.hs b/ouroboros-network/sim-tests/Main.hs index b009ad2f753..a2055ec5558 100644 --- a/ouroboros-network/sim-tests/Main.hs +++ b/ouroboros-network/sim-tests/Main.hs @@ -18,7 +18,6 @@ import Test.Ouroboros.Network.PeerSelection.MockEnvironment qualified import Test.Ouroboros.Network.PeerSelection.PeerMetric qualified import Test.Ouroboros.Network.PeerSelection.PublicRootPeers qualified import Test.Ouroboros.Network.PeerSelection.RootPeersDNS qualified -import Test.Ouroboros.Network.PeerState qualified (tests) import Test.Ouroboros.Network.Testnet qualified (tests) import Test.Ouroboros.Network.Testnet.Policies qualified (tests) import Test.Ouroboros.Network.TxSubmission qualified (tests) @@ -35,7 +34,6 @@ tests = -- network logic , Test.Ouroboros.Network.Version.tests - , Test.Ouroboros.Network.PeerState.tests , Test.Ouroboros.Network.BlockFetch.tests , Test.Ouroboros.Network.PeerSelection.tests , Test.Ouroboros.Network.PeerSelection.Json.tests diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs index 8df27acc6e5..a2346cfebc7 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs @@ -1,115 +1,1124 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +#if !defined(mingw32_HOST_OS) +#define POSIX +#endif + +-- | This module is expected to be imported qualified (it will clash +-- with the "Ouroboros.Network.Diffusion.NonP2P"). +-- module Ouroboros.Network.Diffusion - ( -- * Common API - P2P (..) - , DiffusionTracer (..) - , Tracers (..) + ( Tracers (..) , nullTracers - , ExtraTracers (..) - , Failure (..) , Arguments (..) - , ExtraArguments (..) + , AcceptedConnectionsLimit (..) , Applications (..) - , ExtraApplications (..) - -- * Run data diffusion , run + , Interfaces (..) + , runM + , NodeToNodePeerConnectionHandle -- * Re-exports - , P2P.AbstractTransitionTrace - , PublicPeerSelectionState - , makePublicPeerSelectionStateVar + , AbstractTransitionTrace + , RemoteTransitionTrace ) where -import Control.Exception (IOException) -import Data.Functor (void) + +import Control.Applicative (Alternative) +import Control.Concurrent.Class.MonadMVar (MonadMVar) +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad.Class.MonadAsync (Async, MonadAsync) +import Control.Monad.Class.MonadAsync qualified as Async +import Control.Monad.Class.MonadFork +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI +import Control.Monad.Fix (MonadFix) +import Control.Tracer (Tracer, contramap, nullTracer, traceWith) +import Data.ByteString.Lazy (ByteString) +import Data.Foldable (asum) +import Data.Hashable (Hashable) +import Data.IP (IP) +import Data.IP qualified as IP +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Maybe (catMaybes, maybeToList) +import Data.Proxy (Proxy (..)) +import Data.Typeable (Typeable) +import Data.Void (Void) +import GHC.IO.Exception (IOErrorType (..), IOException (..)) +import System.Exit (ExitCode) +import System.Random (StdGen, newStdGen, split) +#ifdef POSIX +import System.Posix.Signals qualified as Signals +#endif import Network.Socket (Socket) +import Network.Socket qualified as Socket + +import Network.Mux qualified as Mx + +import Ouroboros.Network.Snocket (FileDescriptor, LocalAddress, + LocalSocket (..), Snocket, localSocketFileDescriptor, + makeLocalBearer, makeSocketBearer) +import Ouroboros.Network.Snocket qualified as Snocket +import Ouroboros.Network.Socket (configureSocket, configureSystemdSocket) + +import Ouroboros.Network.Protocol.Handshake +import Ouroboros.Network.Protocol.Handshake.Codec +import Ouroboros.Network.Protocol.Handshake.Version + -import Ouroboros.Network.NodeToClient (LocalAddress, LocalSocket, - NodeToClientVersion, NodeToClientVersionData) -import Ouroboros.Network.NodeToNode (NodeToNodeVersion, NodeToNodeVersionData, - RemoteAddress) -import Ouroboros.Network.PeerSelection.Governor.Types +import Ouroboros.Network.ConnectionHandler +import Ouroboros.Network.ConnectionId +import Ouroboros.Network.ConnectionManager.Core qualified as CM +import Ouroboros.Network.ConnectionManager.InformationChannel + (newInformationChannel) +import Ouroboros.Network.ConnectionManager.State qualified as CM +import Ouroboros.Network.ConnectionManager.Types +import Ouroboros.Network.ConsensusMode +import Ouroboros.Network.Context (ExpandedInitiatorContext, ResponderContext) +import Ouroboros.Network.ExitPolicy +import Ouroboros.Network.InboundGovernor (RemoteTransitionTrace) +import Ouroboros.Network.InboundGovernor qualified as InboundGovernor +import Ouroboros.Network.IOManager +import Ouroboros.Network.Mux hiding (MiniProtocol (..)) +import Ouroboros.Network.MuxMode +import Ouroboros.Network.NodeToClient (NodeToClientVersion (..), + NodeToClientVersionData) +import Ouroboros.Network.NodeToClient qualified as NodeToClient +import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..), + DiffusionMode (..), NodeToNodeVersion (..), + NodeToNodeVersionData (..), RemoteAddress) +import Ouroboros.Network.NodeToNode qualified as NodeToNode +import Ouroboros.Network.PeerSharing (PeerSharingRegistry (..)) +import Ouroboros.Network.RethrowPolicy +import Ouroboros.Network.Server qualified as Server -import Ouroboros.Network.Diffusion.Common as Common -import Ouroboros.Network.Diffusion.NonP2P qualified as NonP2P -import Ouroboros.Network.Diffusion.P2P qualified as P2P +import Ouroboros.Network.PeerSelection.Churn (PeerChurnArgs (..)) +import Ouroboros.Network.PeerSelection.Governor qualified as Governor +import Ouroboros.Network.PeerSelection.LedgerPeers (WithLedgerPeersArgs (..)) +#ifdef POSIX +import Ouroboros.Network.PeerSelection.LedgerPeers.Type + (LedgerPeersConsensusInterface (..)) +#endif +import Ouroboros.Network.PeerSelection.PeerMetric qualified as PeerMetric +import Ouroboros.Network.PeerSelection.PeerSelectionActions +import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) +import Ouroboros.Network.PeerSelection.PeerStateActions (PeerConnectionHandle, + PeerStateActionsArguments (..), pchPeerSharing, withPeerStateActions) +import Ouroboros.Network.PeerSelection.RootPeersDNS +import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions (DNSActions, + DNSLookupType (..), ioDNSActions) +import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers --- | Promoted data types. +import Ouroboros.Network.Diffusion.Policies qualified as Diffusion.Policies +import Ouroboros.Network.Diffusion.Types +import Ouroboros.Network.Diffusion.Utils + + +-- +-- Constants -- -data P2P = P2P | NonP2P --- | Tracers which depend on p2p mode. +-- | Protocol inactivity timeout for local (e.g. /node-to-client/) connections. -- -data ExtraTracers (p2p :: P2P) where - P2PTracers - :: P2P.TracersExtra - RemoteAddress NodeToNodeVersion NodeToNodeVersionData - LocalAddress NodeToClientVersion NodeToClientVersionData - IOException IO - -> ExtraTracers 'P2P +local_PROTOCOL_IDLE_TIMEOUT :: DiffTime +local_PROTOCOL_IDLE_TIMEOUT = 2 -- 2 seconds + +-- | Used to set 'cmWaitTimeout' for local (e.g. /node-to-client/) connections. +-- +local_TIME_WAIT_TIMEOUT :: DiffTime +local_TIME_WAIT_TIMEOUT = 0 + - NonP2PTracers - :: NonP2P.TracersExtra - -> ExtraTracers 'NonP2P +socketAddressType :: Socket.SockAddr -> Maybe AddressType +socketAddressType Socket.SockAddrInet {} = Just IPv4Address +socketAddressType Socket.SockAddrInet6 {} = Just IPv6Address +socketAddressType Socket.SockAddrUnix {} = Nothing --- | Diffusion arguments which depend on p2p mode. -- -data ExtraArguments (p2p :: P2P) m where - P2PArguments - :: P2P.ArgumentsExtra m - -> ExtraArguments 'P2P m +-- Node-To-Client type aliases +-- +-- Node-To-Client diffusion is only used in 'ResponderMode'. +-- + +type NodeToClientHandle ntcAddr versionData m = + HandleWithMinimalCtx Mx.ResponderMode ntcAddr versionData ByteString m Void () + +type NodeToClientHandleError ntcVersion = + HandleError Mx.ResponderMode ntcVersion - NonP2PArguments - :: NonP2P.ArgumentsExtra - -> ExtraArguments 'NonP2P m +type NodeToClientConnectionHandler + ntcFd ntcAddr ntcVersion ntcVersionData m = + ConnectionHandler + Mx.ResponderMode + (ConnectionHandlerTrace ntcVersion ntcVersionData) + ntcFd + ntcAddr + (NodeToClientHandle ntcAddr ntcVersionData m) + (NodeToClientHandleError ntcVersion) + ntcVersion + ntcVersionData + m +type NodeToClientConnectionManagerArguments + ntcFd ntcAddr ntcVersion ntcVersionData m = + CM.Arguments + (ConnectionHandlerTrace ntcVersion ntcVersionData) + ntcFd + ntcAddr + (NodeToClientHandle ntcAddr ntcVersionData m) + (NodeToClientHandleError ntcVersion) + ntcVersion + ntcVersionData + m --- | Application data which depend on p2p mode. + +-- +-- Node-To-Node type aliases +-- +-- Node-To-Node diffusion runs in either 'InitiatorMode' or 'InitiatorResponderMode'. -- -data ExtraApplications (p2p :: P2P) ntnAddr m a where - P2PApplications - :: P2P.ApplicationsExtra ntnAddr m a - -> ExtraApplications 'P2P ntnAddr m a - NonP2PApplications - :: NonP2P.ApplicationsExtra - -> ExtraApplications 'NonP2P ntnAddr m a +type NodeToNodeHandle + (mode :: Mx.Mode) + ntnAddr ntnVersionData m a b = + HandleWithExpandedCtx mode ntnAddr ntnVersionData ByteString m a b +type NodeToNodeConnectionManager + (mode :: Mx.Mode) + ntnFd ntnAddr ntnVersionData ntnVersion m a b = + ConnectionManager + mode + ntnFd + ntnAddr + (NodeToNodeHandle mode ntnAddr ntnVersionData m a b) + (HandleError mode ntnVersion) + m --- | Run data diffusion in either 'P2P' or 'NonP2P' mode. -- -run :: forall (p2p :: P2P) a. - Tracers - RemoteAddress NodeToNodeVersion - LocalAddress NodeToClientVersion - IO - -> ExtraTracers p2p - -> Arguments - IO - Socket RemoteAddress - LocalSocket LocalAddress - -> ExtraArguments p2p IO +-- Governor type aliases +-- + +type NodeToNodePeerConnectionHandle (mode :: Mx.Mode) ntnAddr ntnVersionData m a b = + PeerConnectionHandle + mode + (ResponderContext ntnAddr) + ntnAddr + ntnVersionData + ByteString + m a b + +type NodeToNodePeerSelectionActions (mode :: Mx.Mode) ntnAddr ntnVersionData m a b = + Governor.PeerSelectionActions + ntnAddr + (NodeToNodePeerConnectionHandle mode ntnAddr ntnVersionData m a b) + m + +data Interfaces ntnFd ntnAddr ntnVersion ntnVersionData + ntcFd ntcAddr ntcVersion ntcVersionData + resolver resolverError + m = + Interfaces { + -- | node-to-node snocket + -- + diNtnSnocket + :: Snocket m ntnFd ntnAddr, + + -- | node-to-node 'Mx.MakeBearer' callback + -- + diNtnBearer + :: Mx.MakeBearer m ntnFd, + + -- | node-to-node socket configuration + -- + -- It is used by both inbound and outbound connection. The address is + -- the local address that we can bind to if given (NOTE: for + -- node-to-node connection `Just` is always given). + -- + diNtnConfigureSocket + :: ntnFd -> Maybe ntnAddr -> m (), + + -- | node-to-node systemd socket configuration + -- + diNtnConfigureSystemdSocket + :: ntnFd -> ntnAddr -> m (), + + -- | node-to-node handshake configuration + -- + diNtnHandshakeArguments + :: HandshakeArguments (ConnectionId ntnAddr) ntnVersion ntnVersionData m, + + -- | node-to-node address type + -- + diNtnAddressType + :: ntnAddr -> Maybe AddressType, + + -- | node-to-node data flow used by connection manager to classify + -- negotiated connections + -- + diNtnDataFlow + :: ntnVersionData -> DataFlow, + + -- | remote side peer sharing information used by peer selection governor + -- to decide which peers are available for performing peer sharing + diNtnPeerSharing + :: ntnVersionData -> PeerSharing, + + -- | node-to-node peer address + -- + diNtnToPeerAddr + :: IP -> Socket.PortNumber -> ntnAddr, + + -- | node-to-client snocket + -- + diNtcSnocket + :: Snocket m ntcFd ntcAddr, + + -- | node-to-client 'Mx.MakeBearer' callback + -- + diNtcBearer + :: Mx.MakeBearer m ntcFd, + + -- | node-to-client handshake configuration + -- + diNtcHandshakeArguments + :: HandshakeArguments (ConnectionId ntcAddr) ntcVersion ntcVersionData m, + + -- | node-to-client file descriptor + -- + diNtcGetFileDescriptor + :: ntcFd -> m FileDescriptor, + + -- | diffusion pseudo random generator. It is split between various + -- components that need randomness, e.g. inbound governor, peer + -- selection, policies, etc. + -- + diRng + :: StdGen, + + -- | callback which is used to register @SIGUSR1@ signal handler. + diInstallSigUSR1Handler + :: forall mode x y. + NodeToNodeConnectionManager mode ntnFd ntnAddr ntnVersionData ntnVersion m x y + -> StrictTVar m (Governor.PeerSelectionState ntnAddr (NodeToNodePeerConnectionHandle + mode ntnAddr ntnVersionData m x y)) + -> PeerMetric.PeerMetrics m ntnAddr + -> m (), + + -- | diffusion dns actions + -- + diDnsActions + :: DNSLookupType -> DNSActions resolver resolverError m, + + -- | Update `ntnVersionData` for initiator-only local roots. + diUpdateVersionData + :: ntnVersionData -> DiffusionMode -> ntnVersionData, + + -- | `ConnStateIdSupply` used by the connection-manager for this node. + -- + -- This is exposed for testing, where we use a global + -- `ConnStateIdSupply`. + -- + diConnStateIdSupply + :: CM.ConnStateIdSupply m + } + +runM + :: forall m ntnFd ntnAddr ntnVersion ntnVersionData + ntcFd ntcAddr ntcVersion ntcVersionData + resolver resolverError a. + ( Alternative (STM m) + , MonadAsync m + , MonadDelay m + , MonadEvaluate m + , MonadFix m + , MonadFork m + , MonadLabelledSTM m + , MonadTraceSTM m + , MonadMask m + , MonadThrow (STM m) + , MonadTime m + , MonadTimer m + , MonadMVar m + , Typeable ntnAddr + , Ord ntnAddr + , Show ntnAddr + , Hashable ntnAddr + , Typeable ntnVersion + , Ord ntnVersion + , Show ntnVersion + , Show ntnVersionData + , Typeable ntcAddr + , Ord ntcAddr + , Show ntcAddr + , Ord ntcVersion + , Exception resolverError + ) + => -- | interfaces + Interfaces ntnFd ntnAddr ntnVersion ntnVersionData + ntcFd ntcAddr ntcVersion ntcVersionData + resolver resolverError + m + -> -- | tracers + Tracers ntnAddr ntnVersion ntnVersionData + ntcAddr ntcVersion ntcVersionData + resolverError m + -> -- | configuration + Arguments m ntnFd ntnAddr + ntcFd ntcAddr + -> -- | protocol handlers + Applications ntnAddr ntnVersion ntnVersionData + ntcAddr ntcVersion ntcVersionData + m a + -> m Void +runM Interfaces + { diNtnSnocket + , diNtnBearer + , diNtnConfigureSocket + , diNtnConfigureSystemdSocket + , diNtnHandshakeArguments + , diNtnAddressType + , diNtnDataFlow + , diNtnPeerSharing + , diNtnToPeerAddr + , diNtcSnocket + , diNtcBearer + , diNtcHandshakeArguments + , diNtcGetFileDescriptor + , diRng + , diInstallSigUSR1Handler + , diDnsActions + , diUpdateVersionData + , diConnStateIdSupply + } + Tracers + { dtMuxTracer + , dtLocalMuxTracer + , dtDiffusionTracer = tracer + , dtTracePeerSelectionTracer + , dtTraceChurnCounters + , dtDebugPeerSelectionInitiatorTracer + , dtDebugPeerSelectionInitiatorResponderTracer + , dtTracePeerSelectionCounters + , dtPeerSelectionActionsTracer + , dtTraceLocalRootPeersTracer + , dtTracePublicRootPeersTracer + , dtTraceLedgerPeersTracer + , dtConnectionManagerTracer + , dtConnectionManagerTransitionTracer + , dtServerTracer + , dtInboundGovernorTracer + , dtInboundGovernorTransitionTracer + , dtLocalConnectionManagerTracer + , dtLocalServerTracer + , dtLocalInboundGovernorTracer + } + Arguments + { daIPv4Address + , daIPv6Address + , daLocalAddress + , daAcceptedConnectionsLimit + , daMode = diffusionMode + , daPublicPeerSelectionVar + , daPeerTargets + , daReadLocalRootPeers + , daReadPublicRootPeers + , daConsensusMode + , daMinBigLedgerPeersForTrustedState + , daReadUseBootstrapPeers + , daOwnPeerSharing + , daReadUseLedgerPeers + , daProtocolIdleTimeout + , daTimeWaitTimeout + , daDeadlineChurnInterval + , daBulkChurnInterval + , daReadLedgerPeerSnapshot + } + Applications + { daApplicationInitiatorMode + , daApplicationInitiatorResponderMode + , daLocalResponderApplication + , daLedgerPeersCtx + , daUpdateOutboundConnectionsState + , daRethrowPolicy + , daLocalRethrowPolicy + , daReturnPolicy + , daPeerMetrics + , daBlockFetchMode + , daPeerSharingRegistry + } + = do + -- Thread to which 'RethrowPolicy' will throw fatal exceptions. + mainThreadId <- myThreadId + + Async.runConcurrently + $ asum + $ Async.Concurrently <$> + ( mkRemoteThread mainThreadId + : maybeToList (mkLocalThread mainThreadId <$> daLocalAddress) + ) + + where + (ledgerPeersRng, rng1) = split diRng + (policyRng, rng2) = split rng1 + (churnRng, rng3) = split rng2 + (fuzzRng, rng4) = split rng3 + (cmLocalStdGen, rng5) = split rng4 + (cmStdGen1, cmStdGen2) = split rng5 + + + mkInboundPeersMap :: InboundGovernor.PublicState ntnAddr ntnVersionData + -> Map ntnAddr PeerSharing + mkInboundPeersMap + InboundGovernor.PublicState { InboundGovernor.inboundDuplexPeers } + = + Map.map diNtnPeerSharing inboundDuplexPeers + + -- TODO: this policy should also be used in `PeerStateActions` and + -- `InboundGovernor` (when creating or accepting connections) + rethrowPolicy = + -- Only the 'IOManagerError's are fatal, all the other exceptions in the + -- networking code will only shutdown the bearer (see 'ShutdownPeer' why + -- this is so). + RethrowPolicy (\_ctx err -> + case fromException err of + Just (_ :: IOManagerError) -> ShutdownNode + Nothing -> mempty) + <> + RethrowPolicy (\_ctx err -> + case fromException err of + -- if we are out of file descriptors (either because we exhausted + -- process or system limit) we should shut down the node and let the + -- operator investigate. + -- + -- Refs: + -- * https://hackage.haskell.org/package/ghc-internal-9.1001.0/docs/src/GHC.Internal.Foreign.C.Error.html#errnoToIOError + -- * man socket.2 + -- * man connect.2 + -- * man accept.2 + -- NOTE: many `connect` and `accept` exceptions are classified as + -- `OtherError`, here we only distinguish fatal IO errors (e.g. + -- ones that propagate to the main thread). + -- NOTE: we don't use the rethrow policy for `accept` calls, where + -- all but `ECONNABORTED` are fatal exceptions. + Just IOError { ioe_type } -> + case ioe_type of + ResourceExhausted -> ShutdownNode + -- EAGAIN -- connect, accept + -- EMFILE -- socket, accept + -- ENFILE -- socket, accept + -- ENOBUFS -- socket, accept + -- ENOMEM -- socket, accept + + UnsupportedOperation -> ShutdownNode + -- EADDRNOTAVAIL -- connect + -- EAFNOSUPPRT -- connect + + InvalidArgument -> ShutdownNode + -- EINVAL -- socket, accept + -- ENOTSOCK -- connect + -- EBADF -- connect, accept + + ProtocolError -> ShutdownNode + -- EPROTONOSUPPOPRT -- socket + -- EPROTO -- accept + + _ -> mempty + Nothing -> mempty) + <> + RethrowPolicy (\ctx err -> case (ctx, fromException err) of + -- mux unknown mini-protocol errors on the outbound + -- side are fatal, since this is misconfiguration of the + -- ouroboros-network stack. + (OutboundError, Just Mx.UnknownMiniProtocol {}) + -> ShutdownNode + _ -> mempty) + + + -- | mkLocalThread - create local connection manager + + mkLocalThread :: ThreadId m -> Either ntcFd ntcAddr -> m Void + mkLocalThread mainThreadId localAddr = + withLocalSocket tracer diNtcGetFileDescriptor diNtcSnocket localAddr + $ \localSocket -> do + localInbInfoChannel <- newInformationChannel + + let localConnectionLimits = AcceptedConnectionsLimit maxBound maxBound 0 + + localConnectionHandler :: NodeToClientConnectionHandler + ntcFd ntcAddr ntcVersion ntcVersionData m + localConnectionHandler = + makeConnectionHandler + dtLocalMuxTracer + SingResponderMode + diNtcHandshakeArguments + ( ( \ (OuroborosApplication apps) + -> TemperatureBundle + (WithHot apps) + (WithWarm []) + (WithEstablished []) + ) <$> daLocalResponderApplication ) + (mainThreadId, rethrowPolicy <> daLocalRethrowPolicy) + + localConnectionManagerArguments + :: NodeToClientConnectionManagerArguments + ntcFd ntcAddr ntcVersion ntcVersionData m + localConnectionManagerArguments = + CM.Arguments { + CM.tracer = dtLocalConnectionManagerTracer, + CM.trTracer = nullTracer, -- TODO: issue #3320 + CM.muxTracer = dtLocalMuxTracer, + CM.ipv4Address = Nothing, + CM.ipv6Address = Nothing, + CM.addressType = const Nothing, + CM.snocket = diNtcSnocket, + CM.makeBearer = diNtcBearer, + CM.configureSocket = \_ _ -> return (), + CM.timeWaitTimeout = local_TIME_WAIT_TIMEOUT, + CM.outboundIdleTimeout = local_PROTOCOL_IDLE_TIMEOUT, + CM.connectionDataFlow = ntcDataFlow, + CM.prunePolicy = Diffusion.Policies.prunePolicy, + CM.stdGen = cmLocalStdGen, + CM.connectionsLimits = localConnectionLimits, + CM.updateVersionData = \a _ -> a, + CM.connStateIdSupply = diConnStateIdSupply + } + + CM.with + localConnectionManagerArguments + localConnectionHandler + classifyHandleError + (InResponderMode localInbInfoChannel) + $ \localConnectionManager-> do + -- + -- node-to-client server + -- + traceWith tracer . RunLocalServer + =<< Snocket.getLocalAddr diNtcSnocket localSocket + + Server.with + Server.Arguments { + Server.sockets = localSocket :| [], + Server.snocket = diNtcSnocket, + Server.tracer = dtLocalServerTracer, + Server.trTracer = nullTracer, -- TODO: issue #3320 + Server.debugInboundGovernor = nullTracer, + Server.inboundGovernorTracer = dtLocalInboundGovernorTracer, + Server.inboundIdleTimeout = Nothing, + Server.connectionLimits = localConnectionLimits, + Server.connectionManager = localConnectionManager, + Server.connectionDataFlow = ntcDataFlow, + Server.inboundInfoChannel = localInbInfoChannel + } + (\inboundGovernorThread _ -> Async.wait inboundGovernorThread) + + + -- | mkRemoteThread - create remote connection manager + + mkRemoteThread :: ThreadId m -> m Void + mkRemoteThread mainThreadId = do + let + exitPolicy :: ExitPolicy a + exitPolicy = stdExitPolicy daReturnPolicy + + ipv4Address + <- traverse (either (Snocket.getLocalAddr diNtnSnocket) pure) + daIPv4Address + case ipv4Address of + Just addr | Just IPv4Address <- diNtnAddressType addr + -> pure () + | otherwise + -> throwIO (UnexpectedIPv4Address addr) + Nothing -> pure () + + ipv6Address + <- traverse (either (Snocket.getLocalAddr diNtnSnocket) pure) + daIPv6Address + case ipv6Address of + Just addr | Just IPv6Address <- diNtnAddressType addr + -> pure () + | otherwise + -> throwIO (UnexpectedIPv6Address addr) + Nothing -> pure () + + lookupReqs <- case (ipv4Address, ipv6Address) of + (Just _ , Nothing) -> return LookupReqAOnly + (Nothing, Just _ ) -> return LookupReqAAAAOnly + (Just _ , Just _ ) -> return LookupReqAAndAAAA + (Nothing, Nothing) -> throwIO NoSocket + + -- RNGs used for picking random peers from the ledger and for + -- demoting/promoting peers. + policyRngVar <- newTVarIO policyRng + + churnModeVar <- newTVarIO Governor.ChurnModeNormal + + localRootsVar <- newTVarIO mempty + + peerSelectionTargetsVar <- newTVarIO $ + case daConsensusMode of + PraosMode -> Governor.deadlineTargets daPeerTargets + GenesisMode -> Governor.syncTargets daPeerTargets + + countersVar <- newTVarIO Governor.emptyPeerSelectionCounters + + -- Design notes: + -- - We split the following code into two parts: + -- - Part (a): plumb data flow (in particular arguments and tracersr) + -- and define common functions as a sequence of 'let's in which we + -- define needed 'withXXX' functions (and similar) which + -- - are used in Part (b), + -- - handle the plumbing of tracers, and + -- - capture commonalities between the two cases. + -- + -- - Part (b): capturing the major control-flow of runM: + -- in particular, two different case alternatives in which is captured + -- the monadic flow of the program stripped down to its essence: + --- ``` + -- + -- case diffusionMode of + -- InitiatorOnlyDiffusionMode -> ... + -- InitiatorAndResponderDiffusionMode -> ... + -- ``` + + -- + -- Part (a): plumb data flow and define common functions + -- + + let connectionManagerArguments' + :: forall handle handleError. + PrunePolicy ntnAddr + -> StdGen + -> CM.Arguments + (ConnectionHandlerTrace ntnVersion ntnVersionData) + ntnFd ntnAddr handle handleError ntnVersion ntnVersionData m + connectionManagerArguments' prunePolicy stdGen = + CM.Arguments { + CM.tracer = dtConnectionManagerTracer, + CM.trTracer = + fmap CM.abstractState + `contramap` dtConnectionManagerTransitionTracer, + CM.muxTracer = dtMuxTracer, + CM.ipv4Address, + CM.ipv6Address, + CM.addressType = diNtnAddressType, + CM.snocket = diNtnSnocket, + CM.makeBearer = diNtnBearer, + CM.configureSocket = diNtnConfigureSocket, + CM.connectionDataFlow = diNtnDataFlow, + CM.prunePolicy = prunePolicy, + CM.stdGen, + CM.connectionsLimits = daAcceptedConnectionsLimit, + CM.timeWaitTimeout = daTimeWaitTimeout, + CM.outboundIdleTimeout = daProtocolIdleTimeout, + CM.updateVersionData = diUpdateVersionData, + CM.connStateIdSupply = diConnStateIdSupply + } + + let peerSelectionPolicy = Diffusion.Policies.simplePeerSelectionPolicy + policyRngVar (readTVar churnModeVar) + daPeerMetrics (epErrorDelay exitPolicy) + + let makeConnectionHandler' + :: forall muxMode socket initiatorCtx responderCtx b c. + SingMuxMode muxMode + -> Versions ntnVersion ntnVersionData + (OuroborosBundle muxMode initiatorCtx responderCtx ByteString m b c) + -> MuxConnectionHandler + muxMode socket initiatorCtx responderCtx ntnAddr + ntnVersion ntnVersionData ByteString m b c + makeConnectionHandler' muxMode versions = + makeConnectionHandler + dtMuxTracer + muxMode + diNtnHandshakeArguments + versions + (mainThreadId, rethrowPolicy <> daRethrowPolicy) + + -- | Capture the two variations (InitiatorMode,InitiatorResponderMode) of + -- withConnectionManager: + + withConnectionManagerInitiatorOnlyMode = + CM.with + (connectionManagerArguments' simplePrunePolicy cmStdGen1) + -- Server is not running, it will not be able to + -- advise which connections to prune. It's also not + -- expected that the governor targets will be larger + -- than limits imposed by 'cmConnectionsLimits'. + (makeConnectionHandler' + SingInitiatorMode + daApplicationInitiatorMode) + classifyHandleError + NotInResponderMode + + withConnectionManagerInitiatorAndResponderMode + inbndInfoChannel = + CM.with + (connectionManagerArguments' Diffusion.Policies.prunePolicy cmStdGen2) + (makeConnectionHandler' + SingInitiatorResponderMode + daApplicationInitiatorResponderMode) + classifyHandleError + (InResponderMode inbndInfoChannel) + + -- + -- peer state actions + -- + -- Peer state actions run a job pool in the background which + -- tracks threads forked by 'PeerStateActions' + -- + + let -- | parameterized version of 'withPeerStateActions' + withPeerStateActions' + :: forall (muxMode :: Mx.Mode) responderCtx socket b c. + HasInitiator muxMode ~ True + => MuxConnectionManager + muxMode socket (ExpandedInitiatorContext ntnAddr m) + responderCtx ntnAddr ntnVersionData ntnVersion + ByteString m a b + -> (Governor.PeerStateActions + ntnAddr + (PeerConnectionHandle muxMode responderCtx ntnAddr + ntnVersionData ByteString m a b) + m + -> m c) + -> m c + withPeerStateActions' connectionManager = + withPeerStateActions + PeerStateActionsArguments { + spsTracer = dtPeerSelectionActionsTracer, + spsDeactivateTimeout = Diffusion.Policies.deactivateTimeout, + spsCloseConnectionTimeout = + Diffusion.Policies.closeConnectionTimeout, + spsConnectionManager = connectionManager, + spsExitPolicy = exitPolicy, + spsRethrowPolicy = rethrowPolicy, + spsMainThreadId = mainThreadId + } + + dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore + -- + -- Run peer selection (p2p governor) + -- + let withPeerSelectionActions' + :: forall muxMode responderCtx bytes a1 b c. + m (Map ntnAddr PeerSharing) + -> PeerSelectionActionsDiffusionMode ntnAddr (PeerConnectionHandle muxMode responderCtx ntnAddr ntnVersionData bytes m a1 b) m + -> ( (Async m Void, Async m Void) + -> Governor.PeerSelectionActions + ntnAddr + (PeerConnectionHandle + muxMode responderCtx ntnAddr ntnVersionData bytes m a1 b) + m + -> m c) + -- ^ continuation, receives a handle to the local roots peer provider thread + -- (only if local root peers were non-empty). + -> m c + withPeerSelectionActions' readInboundPeers = + withPeerSelectionActions localRootsVar PeerActionsDNS { + paToPeerAddr = diNtnToPeerAddr, + paDnsActions = diDnsActions lookupReqs, + paDnsSemaphore = dnsSemaphore } + PeerSelectionActionsArgs { + psLocalRootPeersTracer = dtTraceLocalRootPeersTracer, + psPublicRootPeersTracer = dtTracePublicRootPeersTracer, + psReadTargets = readTVar peerSelectionTargetsVar, + getLedgerStateCtx = daLedgerPeersCtx, + psReadLocalRootPeers = daReadLocalRootPeers, + psReadPublicRootPeers = daReadPublicRootPeers, + psReadUseBootstrapPeers = daReadUseBootstrapPeers, + psPeerSharing = daOwnPeerSharing, + psPeerConnToPeerSharing = pchPeerSharing diNtnPeerSharing, + psReadPeerSharingController = readTVar (getPeerSharingRegistry daPeerSharingRegistry), + psReadInboundPeers = + case daOwnPeerSharing of + PeerSharingDisabled -> pure Map.empty + PeerSharingEnabled -> readInboundPeers, + psUpdateOutboundConnectionsState = daUpdateOutboundConnectionsState, + peerTargets = daPeerTargets, + readLedgerPeerSnapshot = daReadLedgerPeerSnapshot } + WithLedgerPeersArgs { + wlpRng = ledgerPeersRng, + wlpConsensusInterface = daLedgerPeersCtx, + wlpTracer = dtTraceLedgerPeersTracer, + wlpGetUseLedgerPeers = daReadUseLedgerPeers, + wlpGetLedgerPeerSnapshot = daReadLedgerPeerSnapshot } + + peerSelectionGovernor' + :: forall (muxMode :: Mx.Mode) b. + Tracer m (Governor.DebugPeerSelection ntnAddr) + -> StrictTVar m (Governor.PeerSelectionState ntnAddr + (NodeToNodePeerConnectionHandle + muxMode ntnAddr ntnVersionData m a b)) + -> NodeToNodePeerSelectionActions muxMode ntnAddr ntnVersionData m a b + -> m Void + peerSelectionGovernor' peerSelectionTracer dbgVar peerSelectionActions = + Governor.peerSelectionGovernor + dtTracePeerSelectionTracer + peerSelectionTracer + dtTracePeerSelectionCounters + fuzzRng + daConsensusMode + daMinBigLedgerPeersForTrustedState + peerSelectionActions + peerSelectionPolicy + Governor.PeerSelectionInterfaces { + Governor.countersVar, + Governor.publicStateVar = daPublicPeerSelectionVar, + Governor.debugStateVar = dbgVar, + Governor.readUseLedgerPeers = daReadUseLedgerPeers + } + + + -- + -- The peer churn governor: + -- + let peerChurnGovernor' = Governor.peerChurnGovernor PeerChurnArgs { + pcaPeerSelectionTracer = dtTracePeerSelectionTracer, + pcaChurnTracer = dtTraceChurnCounters, + pcaDeadlineInterval = daDeadlineChurnInterval, + pcaBulkInterval = daBulkChurnInterval, + pcaPeerRequestTimeout = Governor.policyPeerShareOverallTimeout + peerSelectionPolicy, + pcaMetrics = daPeerMetrics, + pcaModeVar = churnModeVar, + pcaRng = churnRng, + pcaReadFetchMode = daBlockFetchMode, + pcaPeerSelectionVar = peerSelectionTargetsVar, + pcaReadCounters = readTVar countersVar, + peerTargets = daPeerTargets, + pcaReadUseBootstrap = daReadUseBootstrapPeers, + pcaConsensusMode = daConsensusMode, + getLedgerStateCtx = daLedgerPeersCtx, + getLocalRootHotTarget = + LocalRootPeers.hotTarget + . LocalRootPeers.clampToTrustable + . LocalRootPeers.fromGroups + <$> readTVar localRootsVar } + + -- + -- Part (b): capturing the major control-flow of runM: + -- + case diffusionMode of + + -- InitiatorOnly mode, run peer selection only: + InitiatorOnlyDiffusionMode -> + withConnectionManagerInitiatorOnlyMode $ \connectionManager-> do + debugStateVar <- newTVarIO $ Governor.emptyPeerSelectionState fuzzRng daConsensusMode daMinBigLedgerPeersForTrustedState + diInstallSigUSR1Handler connectionManager debugStateVar daPeerMetrics + withPeerStateActions' connectionManager $ \peerStateActions-> + withPeerSelectionActions' + (return Map.empty) + PeerSelectionActionsDiffusionMode { psPeerStateActions = peerStateActions } $ + \(ledgerPeersThread, localRootPeersProvider) peerSelectionActions-> + Async.withAsync + (peerSelectionGovernor' + dtDebugPeerSelectionInitiatorTracer + debugStateVar + peerSelectionActions) $ \governorThread -> + Async.withAsync + peerChurnGovernor' $ \churnGovernorThread -> + -- wait for any thread to fail: + snd <$> Async.waitAny + [ledgerPeersThread, localRootPeersProvider, governorThread, churnGovernorThread] + + -- InitiatorAndResponder mode, run peer selection and the server: + InitiatorAndResponderDiffusionMode -> do + inboundInfoChannel <- newInformationChannel + withConnectionManagerInitiatorAndResponderMode + inboundInfoChannel $ \connectionManager -> + -- + -- node-to-node sockets + -- + withSockets + tracer + diNtnSnocket + (\sock addr -> diNtnConfigureSocket sock (Just addr)) + (\sock addr -> diNtnConfigureSystemdSocket sock addr) + (catMaybes [daIPv4Address, daIPv6Address]) + $ \sockets addresses -> + -- + -- node-to-node server + -- + Server.with + Server.Arguments { + Server.sockets = sockets, + Server.snocket = diNtnSnocket, + Server.tracer = dtServerTracer, + Server.trTracer = dtInboundGovernorTransitionTracer, + Server.debugInboundGovernor = nullTracer, + Server.inboundGovernorTracer = dtInboundGovernorTracer, + Server.connectionLimits = daAcceptedConnectionsLimit, + Server.connectionManager = connectionManager, + Server.connectionDataFlow = diNtnDataFlow, + Server.inboundIdleTimeout = Just daProtocolIdleTimeout, + Server.inboundInfoChannel = inboundInfoChannel + } $ \inboundGovernorThread readInboundState -> do + debugStateVar <- newTVarIO $ Governor.emptyPeerSelectionState fuzzRng daConsensusMode daMinBigLedgerPeersForTrustedState + diInstallSigUSR1Handler connectionManager debugStateVar daPeerMetrics + withPeerStateActions' connectionManager $ \peerStateActions -> + withPeerSelectionActions' + (mkInboundPeersMap <$> readInboundState) + PeerSelectionActionsDiffusionMode { psPeerStateActions = peerStateActions } $ + \(ledgerPeersThread, localRootPeersProvider) peerSelectionActions -> + Async.withAsync + (peerSelectionGovernor' dtDebugPeerSelectionInitiatorResponderTracer debugStateVar peerSelectionActions) $ \governorThread -> do + -- begin, unique to InitiatorAndResponder mode: + traceWith tracer (RunServer addresses) + -- end, unique to ... + Async.withAsync peerChurnGovernor' $ \churnGovernorThread -> + -- wait for any thread to fail: + snd <$> Async.waitAny [ledgerPeersThread, localRootPeersProvider, governorThread, churnGovernorThread, inboundGovernorThread] + +-- | Main entry point for data diffusion service. It allows to: +-- +-- * connect to upstream peers; +-- * accept connection from downstream peers, if run in +-- 'InitiatorAndResponderDiffusionMode'. +-- * runs a local service which allows to use node-to-client protocol to obtain +-- information from the running system. This is used by 'cardano-cli' or +-- a wallet and a like local services. +-- +run + :: Tracers RemoteAddress NodeToNodeVersion NodeToNodeVersionData + LocalAddress NodeToClientVersion NodeToClientVersionData + IOException IO + -> Arguments IO + Socket RemoteAddress + LocalSocket LocalAddress -> Applications - RemoteAddress NodeToNodeVersion NodeToNodeVersionData - LocalAddress NodeToClientVersion NodeToClientVersionData + RemoteAddress NodeToNodeVersion NodeToNodeVersionData + LocalAddress NodeToClientVersion NodeToClientVersionData IO a - -> ExtraApplications p2p RemoteAddress IO a - -> IO () -run tracers (P2PTracers tracersExtra) - args (P2PArguments argsExtra) - apps (P2PApplications appsExtra) = - void $ - P2P.run tracers tracersExtra - args argsExtra - apps appsExtra -run tracers (NonP2PTracers tracersExtra) - args (NonP2PArguments argsExtra) - apps (NonP2PApplications appsExtra) = - NonP2P.run tracers tracersExtra - args argsExtra - apps appsExtra + -> IO Void +run tracers args apps = do + let tracer = dtDiffusionTracer tracers + -- We run two services: for /node-to-node/ and /node-to-client/. The + -- naming convention is that we use /local/ prefix for /node-to-client/ + -- related terms, as this is a local only service running over a unix + -- socket / windows named pipe. + handleJust (\e -> case fromException e :: Maybe ExitCode of + Nothing -> Just e + Just {} -> Nothing) + (\e -> traceWith tracer (DiffusionErrored e) + >> throwIO (DiffusionError e)) + $ withIOManager $ \iocp -> do + let diNtnHandshakeArguments = + HandshakeArguments { + haHandshakeTracer = dtHandshakeTracer tracers, + haHandshakeCodec = NodeToNode.nodeToNodeHandshakeCodec, + haVersionDataCodec = + cborTermVersionDataCodec + NodeToNode.nodeToNodeCodecCBORTerm, + haAcceptVersion = acceptableVersion, + haQueryVersion = queryVersion, + haTimeLimits = timeLimitsHandshake + } + diNtcHandshakeArguments = + HandshakeArguments { + haHandshakeTracer = dtLocalHandshakeTracer tracers, + haHandshakeCodec = NodeToClient.nodeToClientHandshakeCodec, + haVersionDataCodec = + cborTermVersionDataCodec + NodeToClient.nodeToClientCodecCBORTerm, + haAcceptVersion = acceptableVersion, + haQueryVersion = queryVersion, + haTimeLimits = noTimeLimitsHandshake + } + + diInstallSigUSR1Handler + :: forall mode x y ntnconn. + NodeToNodeConnectionManager mode Socket RemoteAddress + NodeToNodeVersionData NodeToNodeVersion IO x y + -> StrictTVar IO (Governor.PeerSelectionState RemoteAddress ntnconn) + -> PeerMetric.PeerMetrics IO RemoteAddress + -> IO () +#ifdef POSIX + diInstallSigUSR1Handler = \connectionManager dbgStateVar metrics -> do + _ <- Signals.installHandler + Signals.sigUSR1 + (Signals.Catch + (do state <- atomically $ readState connectionManager + traceWith (dtConnectionManagerTracer tracers) + (CM.TrState state) + ps <- readTVarIO dbgStateVar + now <- getMonotonicTime + (up, bp, lsj, am) <- atomically $ + (,,,) <$> PeerMetric.upstreamyness metrics + <*> PeerMetric.fetchynessBlocks metrics + <*> lpGetLedgerStateJudgement (daLedgerPeersCtx apps) + <*> Governor.readAssociationMode + (daReadUseLedgerPeers args) + (daOwnPeerSharing args) + (Governor.bootstrapPeersFlag ps) + let dbgState = Governor.makeDebugPeerSelectionState ps up bp lsj am + traceWith (dtTracePeerSelectionTracer tracers) + (Governor.TraceDebugState now dbgState) + ) + ) + Nothing + return () +#else + diInstallSigUSR1Handler = \_ _ _ -> pure () +#endif + + diRng <- newStdGen + diConnStateIdSupply <- atomically $ CM.newConnStateIdSupply Proxy + runM + Interfaces { + diNtnSnocket = Snocket.socketSnocket iocp, + diNtnBearer = makeSocketBearer, + diNtnConfigureSocket = configureSocket, + diNtnConfigureSystemdSocket = + configureSystemdSocket + (SystemdSocketConfiguration `contramap` tracer), + diNtnHandshakeArguments, + diNtnAddressType = socketAddressType, + diNtnDataFlow = ntnDataFlow, + diNtnPeerSharing = peerSharing, + diNtnToPeerAddr = curry IP.toSockAddr, + + diNtcSnocket = Snocket.localSnocket iocp, + diNtcBearer = makeLocalBearer, + diNtcHandshakeArguments, + diNtcGetFileDescriptor = localSocketFileDescriptor, + + diRng, + diInstallSigUSR1Handler, + diDnsActions = ioDNSActions, + diUpdateVersionData = \versionData diffusionMode -> versionData { diffusionMode }, + diConnStateIdSupply + } + tracers args apps + + +-- +-- Data flow +-- + +-- | Node-To-Node protocol connections which negotiated +-- `InitiatorAndResponderDiffusionMode` are `Duplex`. +-- +ntnDataFlow :: NodeToNodeVersionData -> DataFlow +ntnDataFlow NodeToNodeVersionData { diffusionMode } = + case diffusionMode of + InitiatorAndResponderDiffusionMode -> Duplex + InitiatorOnlyDiffusionMode -> Unidirectional + + +-- | All Node-To-Client protocol connections are considered 'Unidirectional'. +-- +ntcDataFlow :: ntcVersionData -> DataFlow +ntcDataFlow _ = Unidirectional diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Common.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Common.hs deleted file mode 100644 index 9e713f5146f..00000000000 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/Common.hs +++ /dev/null @@ -1,206 +0,0 @@ --- Common things between P2P and NonP2P Diffusion modules -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Ouroboros.Network.Diffusion.Common - ( DiffusionTracer (..) - , Failure (..) - , Tracers (..) - , nullTracers - , Arguments (..) - , Applications (..) - ) where - -import Data.ByteString.Lazy (ByteString) -import Data.List.NonEmpty (NonEmpty) -import Data.Typeable (Typeable) -import Data.Void (Void) - -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Exception (Exception, SomeException) -import Control.Tracer (Tracer, nullTracer) - -import Network.Mux qualified as Mx - -import Ouroboros.Network.Mux (OuroborosApplicationWithMinimalCtx, - OuroborosBundleWithExpandedCtx) -import Ouroboros.Network.NodeToClient (Versions) -import Ouroboros.Network.NodeToClient qualified as NodeToClient -import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit, ConnectionId, - DiffusionMode) -import Ouroboros.Network.NodeToNode qualified as NodeToNode -import Ouroboros.Network.PeerSelection.Governor.Types (PublicPeerSelectionState) -import Ouroboros.Network.PeerSelection.LedgerPeers.Type - (LedgerPeersConsensusInterface) -import Ouroboros.Network.PeerSelection.LocalRootPeers (OutboundConnectionsState) -import Ouroboros.Network.Snocket (FileDescriptor) -import Ouroboros.Network.Socket (SystemdSocketTracer) - --- | The 'DiffusionTracer' logs --- --- * diffusion initialisation messages --- * terminal errors thrown by diffusion --- -data DiffusionTracer ntnAddr ntcAddr - = RunServer (NonEmpty ntnAddr) - | RunLocalServer ntcAddr - | UsingSystemdSocket ntcAddr - -- Rename as 'CreateLocalSocket' - | CreateSystemdSocketForSnocketPath ntcAddr - | CreatedLocalSocket ntcAddr - | ConfiguringLocalSocket ntcAddr FileDescriptor - | ListeningLocalSocket ntcAddr FileDescriptor - | LocalSocketUp ntcAddr FileDescriptor - -- Rename as 'CreateServerSocket' - | CreatingServerSocket ntnAddr - | ConfiguringServerSocket ntnAddr - | ListeningServerSocket ntnAddr - | ServerSocketUp ntnAddr - -- Rename as 'UnsupportedLocalSocketType' - | UnsupportedLocalSystemdSocket ntnAddr - -- Remove (this is impossible case), there's no systemd on Windows - | UnsupportedReadySocketCase - | DiffusionErrored SomeException - | SystemdSocketConfiguration SystemdSocketTracer - deriving Show - --- TODO: add a tracer for these misconfiguration -data Failure where - UnsupportedReadySocket :: Failure - UnexpectedIPv4Address :: forall ntnAddr. (Show ntnAddr, Typeable ntnAddr) => ntnAddr -> Failure - UnexpectedIPv6Address :: forall ntnAddr. (Show ntnAddr, Typeable ntnAddr) => ntnAddr -> Failure - NoSocket :: Failure - DiffusionError :: SomeException -> Failure - -deriving instance Show Failure -instance Exception Failure - --- | Common DiffusionTracers interface between P2P and NonP2P --- -data Tracers ntnAddr ntnVersion ntcAddr ntcVersion m = Tracers { - -- | Mux tracer - dtMuxTracer - :: Tracer m (Mx.WithBearer (ConnectionId ntnAddr) Mx.Trace) - - -- | Handshake protocol tracer - , dtHandshakeTracer - :: Tracer m (NodeToNode.HandshakeTr ntnAddr ntnVersion) - - -- - -- NodeToClient tracers - -- - - -- | Mux tracer for local clients - , dtLocalMuxTracer - :: Tracer m (Mx.WithBearer (ConnectionId ntcAddr) Mx.Trace) - - -- | Handshake protocol tracer for local clients - , dtLocalHandshakeTracer - :: Tracer m (NodeToClient.HandshakeTr ntcAddr ntcVersion) - - -- | Diffusion initialisation tracer - , dtDiffusionTracer - :: Tracer m (DiffusionTracer ntnAddr ntcAddr) - } - - -nullTracers :: Applicative m - => Tracers ntnAddr ntnVersion - ntcAddr ntcVersion - m -nullTracers = Tracers { - dtMuxTracer = nullTracer - , dtHandshakeTracer = nullTracer - , dtLocalMuxTracer = nullTracer - , dtLocalHandshakeTracer = nullTracer - , dtDiffusionTracer = nullTracer - } - --- | Common DiffusionArguments interface between P2P and NonP2P --- -data Arguments m ntnFd ntnAddr ntcFd ntcAddr = Arguments { - -- | an @IPv4@ socket ready to accept connections or an @IPv4@ addresses - -- - daIPv4Address :: Maybe (Either ntnFd ntnAddr) - - -- | an @IPv6@ socket ready to accept connections or an @IPv6@ addresses - -- - , daIPv6Address :: Maybe (Either ntnFd ntnAddr) - - -- | an @AF_UNIX@ socket ready to accept connections or an @AF_UNIX@ - -- socket path - , daLocalAddress :: Maybe (Either ntcFd ntcAddr) - - -- | parameters for limiting number of accepted connections - -- - , daAcceptedConnectionsLimit :: AcceptedConnectionsLimit - - -- | run in initiator only mode - -- - , daMode :: DiffusionMode - - -- | public peer selection state - -- - -- It is created outside of diffusion, since it is needed to create some - -- apps (e.g. peer sharing). - -- - , daPublicPeerSelectionVar :: StrictTVar m (PublicPeerSelectionState ntnAddr) - } - - --- | Versioned mini-protocol bundles run on a negotiated connection. --- -data Applications ntnAddr ntnVersion ntnVersionData - ntcAddr ntcVersion ntcVersionData - m a = - Applications { - -- | NodeToNode initiator applications for initiator only mode. - -- - -- TODO: we should accept one or the other, but not both: - -- 'daApplicationInitiatorMode', 'daApplicationInitiatorResponderMode'. - -- - -- Even in non-p2p mode we use p2p apps. - daApplicationInitiatorMode - :: Versions ntnVersion - ntnVersionData - (OuroborosBundleWithExpandedCtx - Mx.InitiatorMode ntnAddr - ByteString m a Void) - - -- | NodeToNode initiator & responder applications for bidirectional mode. - -- - , daApplicationInitiatorResponderMode - -- Peer Sharing result computation callback - :: Versions ntnVersion - ntnVersionData - (OuroborosBundleWithExpandedCtx - Mx.InitiatorResponderMode ntnAddr - ByteString m a ()) - - -- | NodeToClient responder application (server role) - -- - -- Because p2p mode does not infect local connections we we use non-p2p - -- apps. - , daLocalResponderApplication - :: Versions ntcVersion - ntcVersionData - (OuroborosApplicationWithMinimalCtx - Mx.ResponderMode ntcAddr - ByteString m Void ()) - - -- | Interface used to get peers from the current ledger. - -- - -- TODO: it should be in 'InterfaceExtra' - , daLedgerPeersCtx :: LedgerPeersConsensusInterface m - - -- | Callback provided by consensus to inform it if the node is - -- connected to only local roots or also some external peers. - -- - -- This is useful in order for the Bootstrap State Machine to - -- simply refuse to transition from TooOld to YoungEnough while - -- it only has local peers. - -- - , daUpdateOutboundConnectionsState :: OutboundConnectionsState -> STM m () - } diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs index e3df3fe2809..48efad487fe 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs @@ -8,7 +8,6 @@ module Ouroboros.Network.Diffusion.Configuration , MinBigLedgerPeersForTrustedState (..) , defaultNumBootstrapPeers , defaultAcceptedConnectionsLimit - , defaultDiffusionMode , defaultPeerSharing , defaultBlockFetchConfiguration , defaultChainSyncTimeout @@ -23,7 +22,6 @@ module Ouroboros.Network.Diffusion.Configuration , ConsensusModePeerTargets (..) , DiffusionMode (..) , MiniProtocolParameters (..) - , P2P (..) , PeerSelectionTargets (..) , PeerSharing (..) , ConsensusMode (..) @@ -49,7 +47,6 @@ import Ouroboros.Network.BlockFetch (BlockFetchConfiguration (..), import Ouroboros.Network.ConnectionManager.Core (defaultProtocolIdleTimeout, defaultResetTimeout, defaultTimeWaitTimeout) import Ouroboros.Network.ConsensusMode -import Ouroboros.Network.Diffusion (P2P (..)) import Ouroboros.Network.Diffusion.Policies (closeConnectionTimeout, deactivateTimeout, maxChainSyncTimeout, minChainSyncTimeout, peerMetricsConfiguration) @@ -127,11 +124,6 @@ defaultAcceptedConnectionsLimit = acceptedConnectionsSoftLimit = 384, acceptedConnectionsDelay = 5 } --- | Principal mode of network operation --- -defaultDiffusionMode :: P2P -defaultDiffusionMode = NonP2P - -- | Node's peer sharing participation flag -- defaultPeerSharing :: PeerSharing diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/NonP2P.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/NonP2P.hs deleted file mode 100644 index 2d9de752c13..00000000000 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/NonP2P.hs +++ /dev/null @@ -1,510 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | This module is expected to be imported qualified (it will clash --- with the "Ouroboros.Network.Diffusion.P2P"). --- -module Ouroboros.Network.Diffusion.NonP2P - ( TracersExtra (..) - , nullTracers - , ApplicationsExtra (..) - , ArgumentsExtra (..) - , run - ) where - -import Control.Concurrent.Async qualified as Async -import Control.Exception -import Control.Tracer (Tracer, contramap, nullTracer, traceWith) -import Data.Foldable (asum) -import Data.Functor (void) -import Data.Maybe (maybeToList) -import Data.Proxy (Proxy (..)) -import Data.Void (Void) -import System.Exit (ExitCode) - -import Network.Socket (SockAddr, Socket) -import Network.Socket qualified as Socket - -import Network.Mux qualified as Mx - -import Ouroboros.Network.Snocket (LocalAddress, LocalSnocket, LocalSocket (..), - SocketSnocket, localSocketFileDescriptor) -import Ouroboros.Network.Snocket qualified as Snocket -import Ouroboros.Network.Socket (NetworkMutableState, NetworkServerTracers (..), - cleanNetworkMutableState, configureSocket, configureSystemdSocket, - newNetworkMutableState) - -import Ouroboros.Network.Context (ExpandedInitiatorContext (..), - IsBigLedgerPeer (..), MinimalInitiatorContext (..)) -import Ouroboros.Network.ControlMessage (continueForever) -import Ouroboros.Network.Diffusion.Common hiding (nullTracers) -import Ouroboros.Network.ErrorPolicy -import Ouroboros.Network.IOManager -import Ouroboros.Network.Mux -import Ouroboros.Network.NodeToClient (NodeToClientVersion, - NodeToClientVersionData) -import Ouroboros.Network.NodeToClient qualified as NodeToClient -import Ouroboros.Network.NodeToNode (AcceptConnectionsPolicyTrace (..), - DiffusionMode (..), NodeToNodeVersion, NodeToNodeVersionData, - RemoteAddress) -import Ouroboros.Network.NodeToNode qualified as NodeToNode -import Ouroboros.Network.Subscription.Dns -import Ouroboros.Network.Subscription.Ip -import Ouroboros.Network.Subscription.Worker (LocalAddresses (..)) -import Ouroboros.Network.Tracers - --- | NonP2P DiffusionTracers Extras --- -data TracersExtra = TracersExtra { - -- | IP subscription tracer - -- - dtIpSubscriptionTracer - :: Tracer IO (WithIPList (SubscriptionTrace SockAddr)) - - -- | DNS subscription tracer - -- - , dtDnsSubscriptionTracer - :: Tracer IO (WithDomainName (SubscriptionTrace SockAddr)) - - -- | DNS resolver tracer - -- - , dtDnsResolverTracer - :: Tracer IO (WithDomainName DnsTrace) - - , dtErrorPolicyTracer - :: Tracer IO (WithAddr SockAddr ErrorPolicyTrace) - - , dtLocalErrorPolicyTracer - :: Tracer IO (WithAddr LocalAddress ErrorPolicyTrace) - - -- | Trace rate limiting of accepted connections - -- - , dtAcceptPolicyTracer - :: Tracer IO AcceptConnectionsPolicyTrace - } - -nullTracers :: TracersExtra -nullTracers = nonP2PNullTracers - where - nonP2PNullTracers = - TracersExtra { - dtIpSubscriptionTracer = nullTracer - , dtDnsSubscriptionTracer = nullTracer - , dtDnsResolverTracer = nullTracer - , dtErrorPolicyTracer = nullTracer - , dtLocalErrorPolicyTracer = nullTracer - , dtAcceptPolicyTracer = nullTracer - } - --- | NonP2P extra arguments --- -data ArgumentsExtra = ArgumentsExtra { - -- | ip subscription addresses - -- - daIpProducers :: IPSubscriptionTarget - - -- | list of domain names to subscribe to - -- - , daDnsProducers :: [DnsSubscriptionTarget] - } - --- | NonP2P extra applications --- -newtype ApplicationsExtra = ApplicationsExtra { - -- | Error policies - -- - daErrorPolicies :: ErrorPolicies - } - --- | Converts between OuroborosBundle and OuroborosApplication. --- Converts from InitiatorResponderMode to ResponderMode. --- --- Useful for sharing the same Applications modes. --- -mkResponderApp - :: OuroborosBundleWithExpandedCtx Mx.InitiatorResponderMode addr bs m a b - -> OuroborosApplicationWithMinimalCtx Mx.ResponderMode addr bs m Void b -mkResponderApp bundle = - OuroborosApplication $ - foldMap (fmap f) bundle - where - f :: MiniProtocolWithExpandedCtx Mx.InitiatorResponderMode bs addr m a b - -> MiniProtocolWithMinimalCtx Mx.ResponderMode bs addr m Void b - f MiniProtocol { miniProtocolNum - , miniProtocolLimits - , miniProtocolRun = InitiatorAndResponderProtocol _initiator - responder - } = - MiniProtocol { miniProtocolNum - , miniProtocolLimits - , miniProtocolRun = ResponderProtocolOnly responder - } - -run - :: Tracers - RemoteAddress NodeToNodeVersion - LocalAddress NodeToClientVersion - IO - -> TracersExtra - -> Arguments - IO - Socket RemoteAddress - LocalSocket LocalAddress - -> ArgumentsExtra - -> Applications - RemoteAddress NodeToNodeVersion NodeToNodeVersionData - LocalAddress NodeToClientVersion NodeToClientVersionData - IO a - -> ApplicationsExtra - -> IO () -run Tracers - { dtMuxTracer - , dtLocalMuxTracer - , dtHandshakeTracer - , dtLocalHandshakeTracer - , dtDiffusionTracer - } - TracersExtra - { dtIpSubscriptionTracer - , dtDnsSubscriptionTracer - , dtDnsResolverTracer - , dtErrorPolicyTracer - , dtLocalErrorPolicyTracer - , dtAcceptPolicyTracer - } - Arguments - { daIPv4Address - , daIPv6Address - , daLocalAddress - , daAcceptedConnectionsLimit - , daMode = diffusionMode - } - ArgumentsExtra - { daIpProducers - , daDnsProducers - } - applications - ApplicationsExtra - { daErrorPolicies } = - traceException . withIOManager $ \iocp -> do - let -- snocket for remote communication. - snocket :: SocketSnocket - snocket = Snocket.socketSnocket iocp - localSnocket :: LocalSnocket - localSnocket = Snocket.localSnocket iocp - addresses = maybeToList daIPv4Address - ++ maybeToList daIPv6Address - - -- networking mutable state - networkState <- newNetworkMutableState - networkLocalState <- newNetworkMutableState - - lias <- getInitiatorLocalAddresses snocket - - let - dnsSubActions = runDnsSubscriptionWorker snocket networkState lias - <$> daDnsProducers - - serverActions = case diffusionMode of - InitiatorAndResponderDiffusionMode -> - runServer snocket networkState <$> addresses - InitiatorOnlyDiffusionMode -> [] - - localServerAction = runLocalServer localSnocket networkLocalState - <$> maybeToList daLocalAddress - - actions = - [ -- clean state thread - cleanNetworkMutableState networkState - , -- clean local state thread - cleanNetworkMutableState networkLocalState - , -- fork ip subscription - runIpSubscriptionWorker snocket networkState lias - ] - -- fork dns subscriptions - ++ dnsSubActions - -- fork servers for remote peers - ++ serverActions - -- fork server for local clients - ++ localServerAction - - -- Runs all threads in parallel, using Async.Concurrently's Alternative instance - Async.runConcurrently $ asum $ Async.Concurrently <$> actions - - where - traceException :: IO a -> IO a - traceException f = catchJust - (\e -> case fromException e :: Maybe ExitCode of - Nothing -> Just e - Just {} -> Nothing) - f $ \(e :: SomeException) -> do - traceWith dtDiffusionTracer (DiffusionErrored e) - throwIO (DiffusionError e) - - -- - -- We can't share portnumber with our server since we run separate - -- 'MuxInitiatorApplication' and 'MuxResponderApplication' - -- applications instead of a 'MuxInitiatorAndResponderApplication'. - -- This means we don't utilise full duplex connection. - getInitiatorLocalAddresses :: SocketSnocket -> IO (LocalAddresses SockAddr) - getInitiatorLocalAddresses sn = do - localIpv4 <- - case daIPv4Address of - Just (Right ipv4) -> do - return LocalAddresses - { laIpv4 = anyIPv4Addr ipv4 - , laIpv6 = Nothing - , laUnix = Nothing - } - - Just (Left ipv4Sock) -> do - ipv4Addrs <- Snocket.getLocalAddr sn ipv4Sock - return LocalAddresses - { laIpv4 = anyIPv4Addr ipv4Addrs - , laIpv6 = Nothing - , laUnix = Nothing - } - - Nothing -> do - return LocalAddresses - { laIpv4 = Nothing - , laIpv6 = Nothing - , laUnix = Nothing - } - - localIpv6 <- - case daIPv6Address of - Just (Right ipv6) -> do - return LocalAddresses - { laIpv4 = Nothing - , laIpv6 = anyIPv6Addr ipv6 - , laUnix = Nothing - } - - Just (Left ipv6Sock) -> do - ipv6Addrs <- Snocket.getLocalAddr sn ipv6Sock - return LocalAddresses - { laIpv4 = Nothing - , laIpv6 = anyIPv6Addr ipv6Addrs - , laUnix = Nothing - } - - Nothing -> do - return LocalAddresses - { laIpv4 = Nothing - , laIpv6 = Nothing - , laUnix = Nothing - } - - return (localIpv4 <> localIpv6) - where - -- Return an IPv4 address with an ephemeral port number if we use IPv4 - anyIPv4Addr :: SockAddr -> Maybe SockAddr - anyIPv4Addr Socket.SockAddrInet {} = Just (Socket.SockAddrInet 0 0) - anyIPv4Addr _ = Nothing - - -- Return an IPv6 address with an ephemeral port number if we use IPv6 - anyIPv6Addr :: SockAddr -> Maybe SockAddr - anyIPv6Addr Socket.SockAddrInet6 {} = - Just (Socket.SockAddrInet6 0 0 (0, 0, 0, 0) 0) - anyIPv6Addr _ = Nothing - - remoteErrorPolicy, localErrorPolicy :: ErrorPolicies - remoteErrorPolicy = NodeToNode.remoteNetworkErrorPolicy <> daErrorPolicies - localErrorPolicy = NodeToNode.localNetworkErrorPolicy <> daErrorPolicies - - runLocalServer :: LocalSnocket - -> NetworkMutableState LocalAddress - -> Either LocalSocket LocalAddress - -> IO () - runLocalServer sn networkLocalState localAddress = - bracket - localServerInit - localServerCleanup - localServerBody - where - localServerInit :: IO LocalSocket - localServerInit = - case localAddress of -#if defined(mingw32_HOST_OS) - -- Windows uses named pipes so can't take advantage of existing sockets - Left _ -> do - traceWith dtDiffusionTracer UnsupportedReadySocketCase - throwIO UnsupportedReadySocket -#else - Left sd -> do - addr <- Snocket.getLocalAddr sn sd - traceWith dtDiffusionTracer - $ UsingSystemdSocket addr - return sd -#endif - Right addr -> do - traceWith dtDiffusionTracer - $ CreateSystemdSocketForSnocketPath addr - sd <- Snocket.open - sn - (Snocket.addrFamily sn addr) - traceWith dtDiffusionTracer - $ CreatedLocalSocket addr - return sd - - -- We close the socket here, even if it was provided for us. - localServerCleanup :: LocalSocket -> IO () - localServerCleanup = Snocket.close sn - - localServerBody :: LocalSocket -> IO () - localServerBody sd = do - case localAddress of - -- If a socket was provided it should be ready to accept - Left _ -> pure () - Right addr -> do - traceWith dtDiffusionTracer - . ConfiguringLocalSocket addr - =<< localSocketFileDescriptor sd - - Snocket.bind sn sd addr - - traceWith dtDiffusionTracer - . ListeningLocalSocket addr - =<< localSocketFileDescriptor sd - - Snocket.listen sn sd - - traceWith dtDiffusionTracer - . LocalSocketUp addr - =<< localSocketFileDescriptor sd - - traceWith dtDiffusionTracer - . RunLocalServer =<< Snocket.getLocalAddr sn sd - - void $ NodeToClient.withServer - sn - (NetworkServerTracers - dtLocalMuxTracer - dtLocalHandshakeTracer - dtLocalErrorPolicyTracer - dtAcceptPolicyTracer) - networkLocalState - sd - (daLocalResponderApplication applications) - localErrorPolicy - - runServer :: SocketSnocket - -> NetworkMutableState SockAddr - -> Either Socket.Socket SockAddr - -> IO () - runServer sn networkState address = - bracket - ( - case address of - Left sd -> return sd - Right addr -> do - traceWith dtDiffusionTracer - $ CreatingServerSocket addr - Snocket.open sn (Snocket.addrFamily sn addr) - ) - (Snocket.close sn) -- We close the socket here, even if it was provided to us. - (\sd -> do - - addr <- case address of - -- If a socket was provided it should be ready to accept - Left sock -> do - addr <- Snocket.getLocalAddr sn sock - configureSystemdSocket - (SystemdSocketConfiguration `contramap` dtDiffusionTracer) - sd addr - Snocket.getLocalAddr sn sd - Right addr -> do - traceWith dtDiffusionTracer - $ ConfiguringServerSocket addr - configureSocket sd (Just addr) - Snocket.bind sn sd addr - traceWith dtDiffusionTracer - $ ListeningServerSocket addr - Snocket.listen sn sd - traceWith dtDiffusionTracer - $ ServerSocketUp addr - return addr - - traceWith dtDiffusionTracer $ RunServer (pure addr) - - void $ NodeToNode.withServer - sn - (NetworkServerTracers - dtMuxTracer - dtHandshakeTracer - dtErrorPolicyTracer - dtAcceptPolicyTracer) - networkState - daAcceptedConnectionsLimit - sd - -- NonP2P does not use Peer Sharing so the callback is set to return - -- []. - (mkResponderApp - <$> daApplicationInitiatorResponderMode - applications) - remoteErrorPolicy - ) - runIpSubscriptionWorker :: SocketSnocket - -> NetworkMutableState SockAddr - -> LocalAddresses SockAddr - -> IO () - runIpSubscriptionWorker sn networkState la = - void - $ NodeToNode.ipSubscriptionWorker - sn - (NetworkSubscriptionTracers - dtMuxTracer - dtHandshakeTracer - dtErrorPolicyTracer - dtIpSubscriptionTracer) - networkState - SubscriptionParams - { spLocalAddresses = la - , spConnectionAttemptDelay = const Nothing - , spErrorPolicies = remoteErrorPolicy - , spSubscriptionTarget = daIpProducers - } - (contramapInitiatorCtx expandContext . fromOuroborosBundle - <$> daApplicationInitiatorMode applications) - - runDnsSubscriptionWorker :: SocketSnocket - -> NetworkMutableState SockAddr - -> LocalAddresses SockAddr - -> DnsSubscriptionTarget - -> IO () - runDnsSubscriptionWorker sn networkState la dnsProducer = - void - $ NodeToNode.dnsSubscriptionWorker - sn - (NetworkDNSSubscriptionTracers - dtMuxTracer - dtHandshakeTracer - dtErrorPolicyTracer - dtDnsSubscriptionTracer - dtDnsResolverTracer) - networkState - SubscriptionParams - { spLocalAddresses = la - , spConnectionAttemptDelay = const Nothing - , spErrorPolicies = remoteErrorPolicy - , spSubscriptionTarget = dnsProducer - } - (contramapInitiatorCtx expandContext . fromOuroborosBundle - <$> daApplicationInitiatorMode applications) - - --- | Contramap context from `ExpandedInitiatorContext` to `MinimalInitiatorContext`. --- -expandContext :: MinimalInitiatorContext RemoteAddress - -> ExpandedInitiatorContext RemoteAddress IO -expandContext MinimalInitiatorContext { micConnectionId = connId } = - ExpandedInitiatorContext { - eicConnectionId = connId, - eicControlMessage = continueForever Proxy, - eicIsBigLedgerPeer = IsNotBigLedgerPeer - } diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs deleted file mode 100644 index 4accbf9e2b6..00000000000 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs +++ /dev/null @@ -1,1368 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DisambiguateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -#if !defined(mingw32_HOST_OS) -#define POSIX -#endif - --- | This module is expected to be imported qualified (it will clash --- with the "Ouroboros.Network.Diffusion.NonP2P"). --- -module Ouroboros.Network.Diffusion.P2P - ( TracersExtra (..) - , nullTracers - , ArgumentsExtra (..) - , AcceptedConnectionsLimit (..) - , ApplicationsExtra (..) - , run - , Interfaces (..) - , runM - , NodeToNodePeerConnectionHandle - -- * Re-exports - , AbstractTransitionTrace - , RemoteTransitionTrace - ) where - - -import Control.Applicative (Alternative) -import Control.Concurrent.Class.MonadMVar (MonadMVar) -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad.Class.MonadAsync (Async, MonadAsync) -import Control.Monad.Class.MonadAsync qualified as Async -import Control.Monad.Class.MonadFork -import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime.SI -import Control.Monad.Class.MonadTimer.SI -import Control.Monad.Fix (MonadFix) -import Control.Tracer (Tracer, contramap, nullTracer, traceWith) -import Data.ByteString.Lazy (ByteString) -import Data.Foldable (asum) -import Data.Hashable (Hashable) -import Data.IP (IP) -import Data.IP qualified as IP -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Map (Map) -import Data.Map qualified as Map -import Data.Maybe (catMaybes, maybeToList) -import Data.Proxy (Proxy (..)) -import Data.Typeable (Typeable) -import Data.Void (Void) -import GHC.IO.Exception (IOException (..), IOErrorType (..)) -import System.Exit (ExitCode) -import System.Random (StdGen, newStdGen, split) -#ifdef POSIX -import System.Posix.Signals qualified as Signals -#endif - -import Network.Socket (Socket) -import Network.Socket qualified as Socket - -import Network.Mux qualified as Mx - -import Ouroboros.Network.Snocket (FileDescriptor, LocalAddress, - LocalSocket (..), Snocket, localSocketFileDescriptor, - makeLocalBearer, makeSocketBearer) -import Ouroboros.Network.Snocket qualified as Snocket - -import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode) -import Ouroboros.Network.ConnectionId -import Ouroboros.Network.Context (ExpandedInitiatorContext, ResponderContext) -import Ouroboros.Network.Protocol.Handshake -import Ouroboros.Network.Protocol.Handshake.Codec -import Ouroboros.Network.Protocol.Handshake.Version -import Ouroboros.Network.Socket (configureSocket, configureSystemdSocket) - -import Ouroboros.Network.ConnectionHandler -import Ouroboros.Network.ConnectionManager.Core qualified as CM -import Ouroboros.Network.ConnectionManager.State qualified as CM -import Ouroboros.Network.ConnectionManager.InformationChannel - (newInformationChannel) -import Ouroboros.Network.ConnectionManager.Types -import Ouroboros.Network.Diffusion.Common hiding (nullTracers) -import Ouroboros.Network.Diffusion.Policies qualified as Diffusion.Policies -import Ouroboros.Network.Diffusion.Utils -import Ouroboros.Network.ExitPolicy -import Ouroboros.Network.InboundGovernor (RemoteTransitionTrace) -import Ouroboros.Network.InboundGovernor qualified as InboundGovernor -import Ouroboros.Network.IOManager -import Ouroboros.Network.Mux hiding (MiniProtocol (..)) -import Ouroboros.Network.MuxMode -import Ouroboros.Network.NodeToClient (NodeToClientVersion (..), - NodeToClientVersionData) -import Ouroboros.Network.NodeToClient qualified as NodeToClient -import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..), - DiffusionMode (..), NodeToNodeVersion (..), - NodeToNodeVersionData (..), RemoteAddress) -import Ouroboros.Network.NodeToNode qualified as NodeToNode -import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers) -import Ouroboros.Network.PeerSelection.Churn (PeerChurnArgs (..)) -import Ouroboros.Network.PeerSelection.Governor qualified as Governor -import Ouroboros.Network.PeerSelection.Governor.Types - (ChurnMode (ChurnModeNormal), ConsensusModePeerTargets (..), - DebugPeerSelection (..), PeerSelectionActions, PeerSelectionCounters, - PeerSelectionInterfaces (..), PeerSelectionPolicy (..), - PeerSelectionState, TracePeerSelection (..), - emptyPeerSelectionCounters, emptyPeerSelectionState) -#ifdef POSIX -import Ouroboros.Network.PeerSelection.Governor.Types - (makeDebugPeerSelectionState) -#endif -import Ouroboros.Network.PeerSelection.LedgerPeers (TraceLedgerPeers, - WithLedgerPeersArgs (..)) -#ifdef POSIX -import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSnapshot, - LedgerPeersConsensusInterface (..), MinBigLedgerPeersForTrustedState, - UseLedgerPeers) -import Ouroboros.Network.PeerSelection.PeerMetric (PeerMetrics, - fetchynessBlocks, upstreamyness) -#else -import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSnapshot, - MinBigLedgerPeersForTrustedState, UseLedgerPeers) -import Ouroboros.Network.PeerSelection.PeerMetric (PeerMetrics) -#endif -import Ouroboros.Network.ConsensusMode -import Ouroboros.Network.PeerSelection.PeerSelectionActions -import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) -import Ouroboros.Network.PeerSelection.PeerStateActions (PeerConnectionHandle, - PeerSelectionActionsTrace (..), PeerStateActionsArguments (..), - pchPeerSharing, withPeerStateActions) -import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint) -import Ouroboros.Network.PeerSelection.RootPeersDNS -import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions (DNSActions, - DNSLookupType (..), ioDNSActions) -import Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers - (TraceLocalRootPeers) -import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers - (TracePublicRootPeers) -import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers -import Ouroboros.Network.PeerSharing (PeerSharingRegistry (..)) -import Ouroboros.Network.RethrowPolicy -import Ouroboros.Network.Server2 qualified as Server - --- | P2P DiffusionTracers Extras --- -data TracersExtra ntnAddr ntnVersion ntnVersionData - ntcAddr ntcVersion ntcVersionData - resolverError m = - TracersExtra { - dtTraceLocalRootPeersTracer - :: Tracer m (TraceLocalRootPeers ntnAddr resolverError) - - , dtTracePublicRootPeersTracer - :: Tracer m TracePublicRootPeers - - -- | Ledger Peers tracer - , dtTraceLedgerPeersTracer - :: Tracer m TraceLedgerPeers - - , dtTracePeerSelectionTracer - :: Tracer m (TracePeerSelection ntnAddr) - - , dtDebugPeerSelectionInitiatorTracer - :: Tracer m (DebugPeerSelection ntnAddr) - - -- TODO: can be unified with the previous one - , dtDebugPeerSelectionInitiatorResponderTracer - :: Tracer m (DebugPeerSelection ntnAddr) - - , dtTracePeerSelectionCounters - :: Tracer m PeerSelectionCounters - - , dtTraceChurnCounters - :: Tracer m Governor.ChurnCounters - - , dtPeerSelectionActionsTracer - :: Tracer m (PeerSelectionActionsTrace ntnAddr ntnVersion) - - , dtConnectionManagerTracer - :: Tracer m (CM.Trace - ntnAddr - (ConnectionHandlerTrace - ntnVersion - ntnVersionData)) - - , dtConnectionManagerTransitionTracer - :: Tracer m (AbstractTransitionTrace CM.ConnStateId) - - , dtServerTracer - :: Tracer m (Server.Trace ntnAddr) - - , dtInboundGovernorTracer - :: Tracer m (InboundGovernor.Trace ntnAddr) - - , dtInboundGovernorTransitionTracer - :: Tracer m (RemoteTransitionTrace ntnAddr) - - -- - -- NodeToClient tracers - -- - - -- | Connection manager tracer for local clients - , dtLocalConnectionManagerTracer - :: Tracer m (CM.Trace - ntcAddr - (ConnectionHandlerTrace - ntcVersion - ntcVersionData)) - - -- | Server tracer for local clients - , dtLocalServerTracer - :: Tracer m (Server.Trace ntcAddr) - - -- | Inbound protocol governor tracer for local clients - , dtLocalInboundGovernorTracer - :: Tracer m (InboundGovernor.Trace ntcAddr) - } - -nullTracers :: Applicative m - => TracersExtra ntnAddr ntnVersion ntnVersionData - ntcAddr ntcVersion ntcVersionData - resolverError m -nullTracers = - TracersExtra { - dtTraceLocalRootPeersTracer = nullTracer - , dtTracePublicRootPeersTracer = nullTracer - , dtTraceLedgerPeersTracer = nullTracer - , dtTracePeerSelectionTracer = nullTracer - , dtTraceChurnCounters = nullTracer - , dtDebugPeerSelectionInitiatorTracer = nullTracer - , dtDebugPeerSelectionInitiatorResponderTracer = nullTracer - , dtTracePeerSelectionCounters = nullTracer - , dtPeerSelectionActionsTracer = nullTracer - , dtConnectionManagerTracer = nullTracer - , dtConnectionManagerTransitionTracer = nullTracer - , dtServerTracer = nullTracer - , dtInboundGovernorTracer = nullTracer - , dtInboundGovernorTransitionTracer = nullTracer - , dtLocalConnectionManagerTracer = nullTracer - , dtLocalServerTracer = nullTracer - , dtLocalInboundGovernorTracer = nullTracer - } - --- | P2P Arguments Extras --- -data ArgumentsExtra m = ArgumentsExtra { - -- | selection targets for the peer governor - -- - daPeerTargets :: ConsensusModePeerTargets - - , daReadLocalRootPeers :: STM m (LocalRootPeers.Config RelayAccessPoint) - , daReadPublicRootPeers :: STM m (Map RelayAccessPoint PeerAdvertise) - -- | When syncing up, ie. ledgerStateJudgement == TooOld, - -- when this is True we will maintain connection with many big ledger peers - -- to get a strong guarantee that when syncing up we will finish with a true - -- ledger state. When false, we will fall back on the previous algorithms - -- that leverage UseBootstrapPeers flag - , daConsensusMode :: ConsensusMode - -- | For Genesis, this sets the floor for minimum number of - -- active big ledger peers we must be connected to in order - -- to be able to signal trusted state (OutboundConnectionsState) - , daMinBigLedgerPeersForTrustedState :: MinBigLedgerPeersForTrustedState - , daReadUseBootstrapPeers :: STM m UseBootstrapPeers - -- | Depending on configuration, node may provide us with - -- a snapshot of big ledger peers taken at some slot on the chain. - -- These peers may be selected by ledgerPeersThread when requested - -- by the peer selection governor when the node is syncing up. - -- This is especially useful for Genesis consensus mode. - , daReadLedgerPeerSnapshot :: STM m (Maybe LedgerPeerSnapshot) - - -- | Peer's own PeerSharing value. - -- - -- This value comes from the node's configuration file and is static. - , daOwnPeerSharing :: PeerSharing - , daReadUseLedgerPeers :: STM m UseLedgerPeers - - -- | Timeout which starts once all responder protocols are idle. If the - -- responders stay idle for duration of the timeout, the connection will - -- be demoted, if it wasn't used by the p2p-governor it will be closed. - -- - -- Applies to 'Unidirectional' as well as 'Duplex' /node-to-node/ - -- connections. - -- - -- See 'serverProtocolIdleTimeout'. - -- - , daProtocolIdleTimeout :: DiffTime - - -- | Time for which /node-to-node/ connections are kept in - -- 'TerminatingState', it should correspond to the OS configured @TCP@ - -- @TIME_WAIT@ timeout. - -- - -- This timeout will apply to after a connection has been closed, its - -- purpose is to be resilient for delayed packets in the same way @TCP@ - -- is using @TIME_WAIT@. - -- - , daTimeWaitTimeout :: DiffTime - - -- | Churn interval between churn events in deadline mode. A small fuzz - -- is added (max 10 minutes) so that not all nodes churn at the same time. - -- - -- By default it is set to 3300 seconds. - -- - , daDeadlineChurnInterval :: DiffTime - - -- | Churn interval between churn events in bulk sync mode. A small fuzz - -- is added (max 1 minute) so that not all nodes churn at the same time. - -- - -- By default it is set to 300 seconds. - -- - , daBulkChurnInterval :: DiffTime - } - --- --- Constants --- - --- | Protocol inactivity timeout for local (e.g. /node-to-client/) connections. --- -local_PROTOCOL_IDLE_TIMEOUT :: DiffTime -local_PROTOCOL_IDLE_TIMEOUT = 2 -- 2 seconds - --- | Used to set 'cmWaitTimeout' for local (e.g. /node-to-client/) connections. --- -local_TIME_WAIT_TIMEOUT :: DiffTime -local_TIME_WAIT_TIMEOUT = 0 - - -socketAddressType :: Socket.SockAddr -> Maybe AddressType -socketAddressType Socket.SockAddrInet {} = Just IPv4Address -socketAddressType Socket.SockAddrInet6 {} = Just IPv6Address -socketAddressType Socket.SockAddrUnix {} = Nothing - - --- | P2P Applications Extras --- --- TODO: we need initiator only mode for Daedalus, there's no reason why it --- should run a node-to-node server side. --- -data ApplicationsExtra ntnAddr m a = - ApplicationsExtra { - -- | /node-to-node/ rethrow policy - -- - daRethrowPolicy :: RethrowPolicy - - -- | /node-to-node/ return policy - -- - , daReturnPolicy :: ReturnPolicy a - - -- | /node-to-client/ rethrow policy - -- - , daLocalRethrowPolicy :: RethrowPolicy - - -- | 'PeerMetrics' used by peer selection policy (see - -- 'simplePeerSelectionPolicy') - -- - , daPeerMetrics :: PeerMetrics m ntnAddr - - -- | Used by churn-governor - -- - , daBlockFetchMode :: STM m FetchMode - - -- | Used for peer sharing protocol - -- - , daPeerSharingRegistry :: PeerSharingRegistry ntnAddr m - } - - --- --- Node-To-Client type aliases --- --- Node-To-Client diffusion is only used in 'ResponderMode'. --- - -type NodeToClientHandle ntcAddr versionData m = - HandleWithMinimalCtx Mx.ResponderMode ntcAddr versionData ByteString m Void () - -type NodeToClientHandleError ntcVersion = - HandleError Mx.ResponderMode ntcVersion - -type NodeToClientConnectionHandler - ntcFd ntcAddr ntcVersion ntcVersionData m = - ConnectionHandler - Mx.ResponderMode - (ConnectionHandlerTrace ntcVersion ntcVersionData) - ntcFd - ntcAddr - (NodeToClientHandle ntcAddr ntcVersionData m) - (NodeToClientHandleError ntcVersion) - ntcVersion - ntcVersionData - m - -type NodeToClientConnectionManagerArguments - ntcFd ntcAddr ntcVersion ntcVersionData m = - CM.Arguments - (ConnectionHandlerTrace ntcVersion ntcVersionData) - ntcFd - ntcAddr - (NodeToClientHandle ntcAddr ntcVersionData m) - (NodeToClientHandleError ntcVersion) - ntcVersion - ntcVersionData - m - - --- --- Node-To-Node type aliases --- --- Node-To-Node diffusion runs in either 'InitiatorMode' or 'InitiatorResponderMode'. --- - -type NodeToNodeHandle - (mode :: Mx.Mode) - ntnAddr ntnVersionData m a b = - HandleWithExpandedCtx mode ntnAddr ntnVersionData ByteString m a b - -type NodeToNodeConnectionManager - (mode :: Mx.Mode) - ntnFd ntnAddr ntnVersionData ntnVersion m a b = - ConnectionManager - mode - ntnFd - ntnAddr - (NodeToNodeHandle mode ntnAddr ntnVersionData m a b) - (HandleError mode ntnVersion) - m - --- --- Governor type aliases --- - -type NodeToNodePeerConnectionHandle (mode :: Mx.Mode) ntnAddr ntnVersionData m a b = - PeerConnectionHandle - mode - (ResponderContext ntnAddr) - ntnAddr - ntnVersionData - ByteString - m a b - -type NodeToNodePeerSelectionActions (mode :: Mx.Mode) ntnAddr ntnVersionData m a b = - PeerSelectionActions - ntnAddr - (NodeToNodePeerConnectionHandle mode ntnAddr ntnVersionData m a b) - m - -data Interfaces ntnFd ntnAddr ntnVersion ntnVersionData - ntcFd ntcAddr ntcVersion ntcVersionData - resolver resolverError - m = - Interfaces { - -- | node-to-node snocket - -- - diNtnSnocket - :: Snocket m ntnFd ntnAddr, - - -- | node-to-node 'Mx.MakeBearer' callback - -- - diNtnBearer - :: Mx.MakeBearer m ntnFd, - - -- | node-to-node socket configuration - -- - -- It is used by both inbound and outbound connection. The address is - -- the local address that we can bind to if given (NOTE: for - -- node-to-node connection `Just` is always given). - -- - diNtnConfigureSocket - :: ntnFd -> Maybe ntnAddr -> m (), - - -- | node-to-node systemd socket configuration - -- - diNtnConfigureSystemdSocket - :: ntnFd -> ntnAddr -> m (), - - -- | node-to-node handshake configuration - -- - diNtnHandshakeArguments - :: HandshakeArguments (ConnectionId ntnAddr) ntnVersion ntnVersionData m, - - -- | node-to-node address type - -- - diNtnAddressType - :: ntnAddr -> Maybe AddressType, - - -- | node-to-node data flow used by connection manager to classify - -- negotiated connections - -- - diNtnDataFlow - :: ntnVersionData -> DataFlow, - - -- | remote side peer sharing information used by peer selection governor - -- to decide which peers are available for performing peer sharing - diNtnPeerSharing - :: ntnVersionData -> PeerSharing, - - -- | node-to-node peer address - -- - diNtnToPeerAddr - :: IP -> Socket.PortNumber -> ntnAddr, - - -- | node-to-client snocket - -- - diNtcSnocket - :: Snocket m ntcFd ntcAddr, - - -- | node-to-client 'Mx.MakeBearer' callback - -- - diNtcBearer - :: Mx.MakeBearer m ntcFd, - - -- | node-to-client handshake configuration - -- - diNtcHandshakeArguments - :: HandshakeArguments (ConnectionId ntcAddr) ntcVersion ntcVersionData m, - - -- | node-to-client file descriptor - -- - diNtcGetFileDescriptor - :: ntcFd -> m FileDescriptor, - - -- | diffusion pseudo random generator. It is split between various - -- components that need randomness, e.g. inbound governor, peer - -- selection, policies, etc. - -- - diRng - :: StdGen, - - -- | callback which is used to register @SIGUSR1@ signal handler. - diInstallSigUSR1Handler - :: forall mode x y. - NodeToNodeConnectionManager mode ntnFd ntnAddr ntnVersionData ntnVersion m x y - -> StrictTVar m (PeerSelectionState ntnAddr (NodeToNodePeerConnectionHandle - mode ntnAddr ntnVersionData m x y)) - -> PeerMetrics m ntnAddr - -> m (), - - -- | diffusion dns actions - -- - diDnsActions - :: DNSLookupType -> DNSActions resolver resolverError m, - - -- | Update `ntnVersionData` for initiator-only local roots. - diUpdateVersionData - :: ntnVersionData -> DiffusionMode -> ntnVersionData, - - -- | `ConnStateIdSupply` used by the connection-manager for this node. - -- - -- This is exposed for testing, where we use a global - -- `ConnStateIdSupply`. - -- - diConnStateIdSupply - :: CM.ConnStateIdSupply m - } - -runM - :: forall m ntnFd ntnAddr ntnVersion ntnVersionData - ntcFd ntcAddr ntcVersion ntcVersionData - resolver resolverError a. - ( Alternative (STM m) - , MonadAsync m - , MonadDelay m - , MonadEvaluate m - , MonadFix m - , MonadFork m - , MonadLabelledSTM m - , MonadTraceSTM m - , MonadMask m - , MonadThrow (STM m) - , MonadTime m - , MonadTimer m - , MonadMVar m - , Typeable ntnAddr - , Ord ntnAddr - , Show ntnAddr - , Hashable ntnAddr - , Typeable ntnVersion - , Ord ntnVersion - , Show ntnVersion - , Show ntnVersionData - , Typeable ntcAddr - , Ord ntcAddr - , Show ntcAddr - , Ord ntcVersion - , Exception resolverError - ) - => -- | interfaces - Interfaces ntnFd ntnAddr ntnVersion ntnVersionData - ntcFd ntcAddr ntcVersion ntcVersionData - resolver resolverError - m - -> -- | tracers - Tracers ntnAddr ntnVersion - ntcAddr ntcVersion - m - -> -- | p2p tracers - TracersExtra ntnAddr ntnVersion ntnVersionData - ntcAddr ntcVersion ntcVersionData - resolverError m - -> -- | configuration - Arguments m ntnFd ntnAddr - ntcFd ntcAddr - -> -- | p2p configuration - ArgumentsExtra m - - -> -- | protocol handlers - Applications ntnAddr ntnVersion ntnVersionData - ntcAddr ntcVersion ntcVersionData - m a - -> -- | p2p protocol handlers - ApplicationsExtra ntnAddr m a - -> m Void -runM Interfaces - { diNtnSnocket - , diNtnBearer - , diNtnConfigureSocket - , diNtnConfigureSystemdSocket - , diNtnHandshakeArguments - , diNtnAddressType - , diNtnDataFlow - , diNtnPeerSharing - , diNtnToPeerAddr - , diNtcSnocket - , diNtcBearer - , diNtcHandshakeArguments - , diNtcGetFileDescriptor - , diRng - , diInstallSigUSR1Handler - , diDnsActions - , diUpdateVersionData - , diConnStateIdSupply - } - Tracers - { dtMuxTracer - , dtLocalMuxTracer - , dtDiffusionTracer = tracer - } - TracersExtra - { dtTracePeerSelectionTracer - , dtTraceChurnCounters - , dtDebugPeerSelectionInitiatorTracer - , dtDebugPeerSelectionInitiatorResponderTracer - , dtTracePeerSelectionCounters - , dtPeerSelectionActionsTracer - , dtTraceLocalRootPeersTracer - , dtTracePublicRootPeersTracer - , dtTraceLedgerPeersTracer - , dtConnectionManagerTracer - , dtConnectionManagerTransitionTracer - , dtServerTracer - , dtInboundGovernorTracer - , dtInboundGovernorTransitionTracer - , dtLocalConnectionManagerTracer - , dtLocalServerTracer - , dtLocalInboundGovernorTracer - } - Arguments - { daIPv4Address - , daIPv6Address - , daLocalAddress - , daAcceptedConnectionsLimit - , daMode = diffusionMode - , daPublicPeerSelectionVar - } - ArgumentsExtra - { daPeerTargets - , daReadLocalRootPeers - , daReadPublicRootPeers - , daConsensusMode - , daMinBigLedgerPeersForTrustedState - , daReadUseBootstrapPeers - , daOwnPeerSharing - , daReadUseLedgerPeers - , daProtocolIdleTimeout - , daTimeWaitTimeout - , daDeadlineChurnInterval - , daBulkChurnInterval - , daReadLedgerPeerSnapshot - } - Applications - { daApplicationInitiatorMode - , daApplicationInitiatorResponderMode - , daLocalResponderApplication - , daLedgerPeersCtx - , daUpdateOutboundConnectionsState - } - ApplicationsExtra - { daRethrowPolicy - , daLocalRethrowPolicy - , daReturnPolicy - , daPeerMetrics - , daBlockFetchMode - , daPeerSharingRegistry - } - = do - -- Thread to which 'RethrowPolicy' will throw fatal exceptions. - mainThreadId <- myThreadId - - Async.runConcurrently - $ asum - $ Async.Concurrently <$> - ( mkRemoteThread mainThreadId - : maybeToList (mkLocalThread mainThreadId <$> daLocalAddress) - ) - - where - (ledgerPeersRng, rng1) = split diRng - (policyRng, rng2) = split rng1 - (churnRng, rng3) = split rng2 - (fuzzRng, rng4) = split rng3 - (cmLocalStdGen, rng5) = split rng4 - (cmStdGen1, cmStdGen2) = split rng5 - - - mkInboundPeersMap :: InboundGovernor.PublicState ntnAddr ntnVersionData - -> Map ntnAddr PeerSharing - mkInboundPeersMap - InboundGovernor.PublicState { InboundGovernor.inboundDuplexPeers } - = - Map.map diNtnPeerSharing inboundDuplexPeers - - -- TODO: this policy should also be used in `PeerStateActions` and - -- `InboundGovernor` (when creating or accepting connections) - rethrowPolicy = - -- Only the 'IOManagerError's are fatal, all the other exceptions in the - -- networking code will only shutdown the bearer (see 'ShutdownPeer' why - -- this is so). - RethrowPolicy (\_ctx err -> - case fromException err of - Just (_ :: IOManagerError) -> ShutdownNode - Nothing -> mempty) - <> - RethrowPolicy (\_ctx err -> - case fromException err of - -- if we are out of file descriptors (either because we exhausted - -- process or system limit) we should shut down the node and let the - -- operator investigate. - -- - -- Refs: - -- * https://hackage.haskell.org/package/ghc-internal-9.1001.0/docs/src/GHC.Internal.Foreign.C.Error.html#errnoToIOError - -- * man socket.2 - -- * man connect.2 - -- * man accept.2 - -- NOTE: many `connect` and `accept` exceptions are classified as - -- `OtherError`, here we only distinguish fatal IO errors (e.g. - -- ones that propagate to the main thread). - -- NOTE: we don't use the rethrow policy for `accept` calls, where - -- all but `ECONNABORTED` are fatal exceptions. - Just IOError { ioe_type } -> - case ioe_type of - ResourceExhausted -> ShutdownNode - -- EAGAIN -- connect, accept - -- EMFILE -- socket, accept - -- ENFILE -- socket, accept - -- ENOBUFS -- socket, accept - -- ENOMEM -- socket, accept - - UnsupportedOperation -> ShutdownNode - -- EADDRNOTAVAIL -- connect - -- EAFNOSUPPRT -- connect - - InvalidArgument -> ShutdownNode - -- EINVAL -- socket, accept - -- ENOTSOCK -- connect - -- EBADF -- connect, accept - - ProtocolError -> ShutdownNode - -- EPROTONOSUPPOPRT -- socket - -- EPROTO -- accept - - _ -> mempty - Nothing -> mempty) - <> - RethrowPolicy (\ctx err -> case (ctx, fromException err) of - -- mux unknown mini-protocol errors on the outbound - -- side are fatal, since this is misconfiguration of the - -- ouroboros-network stack. - (OutboundError, Just Mx.UnknownMiniProtocol {}) - -> ShutdownNode - _ -> mempty) - - - -- | mkLocalThread - create local connection manager - - mkLocalThread :: ThreadId m -> Either ntcFd ntcAddr -> m Void - mkLocalThread mainThreadId localAddr = - withLocalSocket tracer diNtcGetFileDescriptor diNtcSnocket localAddr - $ \localSocket -> do - localInbInfoChannel <- newInformationChannel - - let localConnectionLimits = AcceptedConnectionsLimit maxBound maxBound 0 - - localConnectionHandler :: NodeToClientConnectionHandler - ntcFd ntcAddr ntcVersion ntcVersionData m - localConnectionHandler = - makeConnectionHandler - dtLocalMuxTracer - SingResponderMode - diNtcHandshakeArguments - ( ( \ (OuroborosApplication apps) - -> TemperatureBundle - (WithHot apps) - (WithWarm []) - (WithEstablished []) - ) <$> daLocalResponderApplication ) - (mainThreadId, rethrowPolicy <> daLocalRethrowPolicy) - - localConnectionManagerArguments - :: NodeToClientConnectionManagerArguments - ntcFd ntcAddr ntcVersion ntcVersionData m - localConnectionManagerArguments = - CM.Arguments { - CM.tracer = dtLocalConnectionManagerTracer, - CM.trTracer = nullTracer, -- TODO: issue #3320 - CM.muxTracer = dtLocalMuxTracer, - CM.ipv4Address = Nothing, - CM.ipv6Address = Nothing, - CM.addressType = const Nothing, - CM.snocket = diNtcSnocket, - CM.makeBearer = diNtcBearer, - CM.configureSocket = \_ _ -> return (), - CM.timeWaitTimeout = local_TIME_WAIT_TIMEOUT, - CM.outboundIdleTimeout = local_PROTOCOL_IDLE_TIMEOUT, - CM.connectionDataFlow = ntcDataFlow, - CM.prunePolicy = Diffusion.Policies.prunePolicy, - CM.stdGen = cmLocalStdGen, - CM.connectionsLimits = localConnectionLimits, - CM.updateVersionData = \a _ -> a, - CM.connStateIdSupply = diConnStateIdSupply - } - - CM.with - localConnectionManagerArguments - localConnectionHandler - classifyHandleError - (InResponderMode localInbInfoChannel) - $ \localConnectionManager-> do - -- - -- node-to-client server - -- - traceWith tracer . RunLocalServer - =<< Snocket.getLocalAddr diNtcSnocket localSocket - - Server.with - Server.Arguments { - Server.sockets = localSocket :| [], - Server.snocket = diNtcSnocket, - Server.tracer = dtLocalServerTracer, - Server.trTracer = nullTracer, -- TODO: issue #3320 - Server.debugInboundGovernor = nullTracer, - Server.inboundGovernorTracer = dtLocalInboundGovernorTracer, - Server.inboundIdleTimeout = Nothing, - Server.connectionLimits = localConnectionLimits, - Server.connectionManager = localConnectionManager, - Server.connectionDataFlow = ntcDataFlow, - Server.inboundInfoChannel = localInbInfoChannel - } - (\inboundGovernorThread _ -> Async.wait inboundGovernorThread) - - - -- | mkRemoteThread - create remote connection manager - - mkRemoteThread :: ThreadId m -> m Void - mkRemoteThread mainThreadId = do - let - exitPolicy :: ExitPolicy a - exitPolicy = stdExitPolicy daReturnPolicy - - ipv4Address - <- traverse (either (Snocket.getLocalAddr diNtnSnocket) pure) - daIPv4Address - case ipv4Address of - Just addr | Just IPv4Address <- diNtnAddressType addr - -> pure () - | otherwise - -> throwIO (UnexpectedIPv4Address addr) - Nothing -> pure () - - ipv6Address - <- traverse (either (Snocket.getLocalAddr diNtnSnocket) pure) - daIPv6Address - case ipv6Address of - Just addr | Just IPv6Address <- diNtnAddressType addr - -> pure () - | otherwise - -> throwIO (UnexpectedIPv6Address addr) - Nothing -> pure () - - lookupReqs <- case (ipv4Address, ipv6Address) of - (Just _ , Nothing) -> return LookupReqAOnly - (Nothing, Just _ ) -> return LookupReqAAAAOnly - (Just _ , Just _ ) -> return LookupReqAAndAAAA - (Nothing, Nothing) -> throwIO NoSocket - - -- RNGs used for picking random peers from the ledger and for - -- demoting/promoting peers. - policyRngVar <- newTVarIO policyRng - - churnModeVar <- newTVarIO ChurnModeNormal - - localRootsVar <- newTVarIO mempty - - peerSelectionTargetsVar <- newTVarIO $ - case daConsensusMode of - PraosMode -> deadlineTargets daPeerTargets - GenesisMode -> syncTargets daPeerTargets - - countersVar <- newTVarIO emptyPeerSelectionCounters - - -- Design notes: - -- - We split the following code into two parts: - -- - Part (a): plumb data flow (in particular arguments and tracersr) - -- and define common functions as a sequence of 'let's in which we - -- define needed 'withXXX' functions (and similar) which - -- - are used in Part (b), - -- - handle the plumbing of tracers, and - -- - capture commonalities between the two cases. - -- - -- - Part (b): capturing the major control-flow of runM: - -- in particular, two different case alternatives in which is captured - -- the monadic flow of the program stripped down to its essence: - --- ``` - -- - -- case diffusionMode of - -- InitiatorOnlyDiffusionMode -> ... - -- InitiatorAndResponderDiffusionMode -> ... - -- ``` - - -- - -- Part (a): plumb data flow and define common functions - -- - - let connectionManagerArguments' - :: forall handle handleError. - PrunePolicy ntnAddr - -> StdGen - -> CM.Arguments - (ConnectionHandlerTrace ntnVersion ntnVersionData) - ntnFd ntnAddr handle handleError ntnVersion ntnVersionData m - connectionManagerArguments' prunePolicy stdGen = - CM.Arguments { - CM.tracer = dtConnectionManagerTracer, - CM.trTracer = - fmap CM.abstractState - `contramap` dtConnectionManagerTransitionTracer, - CM.muxTracer = dtMuxTracer, - CM.ipv4Address, - CM.ipv6Address, - CM.addressType = diNtnAddressType, - CM.snocket = diNtnSnocket, - CM.makeBearer = diNtnBearer, - CM.configureSocket = diNtnConfigureSocket, - CM.connectionDataFlow = diNtnDataFlow, - CM.prunePolicy = prunePolicy, - CM.stdGen, - CM.connectionsLimits = daAcceptedConnectionsLimit, - CM.timeWaitTimeout = daTimeWaitTimeout, - CM.outboundIdleTimeout = daProtocolIdleTimeout, - CM.updateVersionData = diUpdateVersionData, - CM.connStateIdSupply = diConnStateIdSupply - } - - let peerSelectionPolicy = Diffusion.Policies.simplePeerSelectionPolicy - policyRngVar (readTVar churnModeVar) - daPeerMetrics (epErrorDelay exitPolicy) - - let makeConnectionHandler' - :: forall muxMode socket initiatorCtx responderCtx b c. - SingMuxMode muxMode - -> Versions ntnVersion ntnVersionData - (OuroborosBundle muxMode initiatorCtx responderCtx ByteString m b c) - -> MuxConnectionHandler - muxMode socket initiatorCtx responderCtx ntnAddr - ntnVersion ntnVersionData ByteString m b c - makeConnectionHandler' muxMode versions = - makeConnectionHandler - dtMuxTracer - muxMode - diNtnHandshakeArguments - versions - (mainThreadId, rethrowPolicy <> daRethrowPolicy) - - -- | Capture the two variations (InitiatorMode,InitiatorResponderMode) of - -- withConnectionManager: - - withConnectionManagerInitiatorOnlyMode = - CM.with - (connectionManagerArguments' simplePrunePolicy cmStdGen1) - -- Server is not running, it will not be able to - -- advise which connections to prune. It's also not - -- expected that the governor targets will be larger - -- than limits imposed by 'cmConnectionsLimits'. - (makeConnectionHandler' - SingInitiatorMode - daApplicationInitiatorMode) - classifyHandleError - NotInResponderMode - - withConnectionManagerInitiatorAndResponderMode - inbndInfoChannel = - CM.with - (connectionManagerArguments' Diffusion.Policies.prunePolicy cmStdGen2) - (makeConnectionHandler' - SingInitiatorResponderMode - daApplicationInitiatorResponderMode) - classifyHandleError - (InResponderMode inbndInfoChannel) - - -- - -- peer state actions - -- - -- Peer state actions run a job pool in the background which - -- tracks threads forked by 'PeerStateActions' - -- - - let -- | parameterized version of 'withPeerStateActions' - withPeerStateActions' - :: forall (muxMode :: Mx.Mode) responderCtx socket b c. - HasInitiator muxMode ~ True - => MuxConnectionManager - muxMode socket (ExpandedInitiatorContext ntnAddr m) - responderCtx ntnAddr ntnVersionData ntnVersion - ByteString m a b - -> (Governor.PeerStateActions - ntnAddr - (PeerConnectionHandle muxMode responderCtx ntnAddr - ntnVersionData ByteString m a b) - m - -> m c) - -> m c - withPeerStateActions' connectionManager = - withPeerStateActions - PeerStateActionsArguments { - spsTracer = dtPeerSelectionActionsTracer, - spsDeactivateTimeout = Diffusion.Policies.deactivateTimeout, - spsCloseConnectionTimeout = - Diffusion.Policies.closeConnectionTimeout, - spsConnectionManager = connectionManager, - spsExitPolicy = exitPolicy, - spsRethrowPolicy = rethrowPolicy, - spsMainThreadId = mainThreadId - } - - dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore - -- - -- Run peer selection (p2p governor) - -- - let withPeerSelectionActions' - :: forall muxMode responderCtx bytes a1 b c. - m (Map ntnAddr PeerSharing) - -> PeerSelectionActionsDiffusionMode ntnAddr (PeerConnectionHandle muxMode responderCtx ntnAddr ntnVersionData bytes m a1 b) m - -> ( (Async m Void, Async m Void) - -> PeerSelectionActions - ntnAddr - (PeerConnectionHandle - muxMode responderCtx ntnAddr ntnVersionData bytes m a1 b) - m - -> m c) - -- ^ continuation, receives a handle to the local roots peer provider thread - -- (only if local root peers were non-empty). - -> m c - withPeerSelectionActions' readInboundPeers = - withPeerSelectionActions localRootsVar PeerActionsDNS { - paToPeerAddr = diNtnToPeerAddr, - paDnsActions = diDnsActions lookupReqs, - paDnsSemaphore = dnsSemaphore } - PeerSelectionActionsArgs { - psLocalRootPeersTracer = dtTraceLocalRootPeersTracer, - psPublicRootPeersTracer = dtTracePublicRootPeersTracer, - psReadTargets = readTVar peerSelectionTargetsVar, - getLedgerStateCtx = daLedgerPeersCtx, - psReadLocalRootPeers = daReadLocalRootPeers, - psReadPublicRootPeers = daReadPublicRootPeers, - psReadUseBootstrapPeers = daReadUseBootstrapPeers, - psPeerSharing = daOwnPeerSharing, - psPeerConnToPeerSharing = pchPeerSharing diNtnPeerSharing, - psReadPeerSharingController = readTVar (getPeerSharingRegistry daPeerSharingRegistry), - psReadInboundPeers = - case daOwnPeerSharing of - PeerSharingDisabled -> pure Map.empty - PeerSharingEnabled -> readInboundPeers, - psUpdateOutboundConnectionsState = daUpdateOutboundConnectionsState, - peerTargets = daPeerTargets, - readLedgerPeerSnapshot = daReadLedgerPeerSnapshot } - WithLedgerPeersArgs { - wlpRng = ledgerPeersRng, - wlpConsensusInterface = daLedgerPeersCtx, - wlpTracer = dtTraceLedgerPeersTracer, - wlpGetUseLedgerPeers = daReadUseLedgerPeers, - wlpGetLedgerPeerSnapshot = daReadLedgerPeerSnapshot } - - peerSelectionGovernor' - :: forall (muxMode :: Mx.Mode) b. - Tracer m (DebugPeerSelection ntnAddr) - -> StrictTVar m (PeerSelectionState ntnAddr - (NodeToNodePeerConnectionHandle - muxMode ntnAddr ntnVersionData m a b)) - -> NodeToNodePeerSelectionActions muxMode ntnAddr ntnVersionData m a b - -> m Void - peerSelectionGovernor' peerSelectionTracer dbgVar peerSelectionActions = - Governor.peerSelectionGovernor - dtTracePeerSelectionTracer - peerSelectionTracer - dtTracePeerSelectionCounters - fuzzRng - daConsensusMode - daMinBigLedgerPeersForTrustedState - peerSelectionActions - peerSelectionPolicy - PeerSelectionInterfaces { - countersVar, - publicStateVar = daPublicPeerSelectionVar, - debugStateVar = dbgVar, - readUseLedgerPeers = daReadUseLedgerPeers - } - - - -- - -- The peer churn governor: - -- - let peerChurnGovernor' = Governor.peerChurnGovernor PeerChurnArgs { - pcaPeerSelectionTracer = dtTracePeerSelectionTracer, - pcaChurnTracer = dtTraceChurnCounters, - pcaDeadlineInterval = daDeadlineChurnInterval, - pcaBulkInterval = daBulkChurnInterval, - pcaPeerRequestTimeout = policyPeerShareOverallTimeout - peerSelectionPolicy, - pcaMetrics = daPeerMetrics, - pcaModeVar = churnModeVar, - pcaRng = churnRng, - pcaReadFetchMode = daBlockFetchMode, - pcaPeerSelectionVar = peerSelectionTargetsVar, - pcaReadCounters = readTVar countersVar, - peerTargets = daPeerTargets, - pcaReadUseBootstrap = daReadUseBootstrapPeers, - pcaConsensusMode = daConsensusMode, - getLedgerStateCtx = daLedgerPeersCtx, - getLocalRootHotTarget = - LocalRootPeers.hotTarget - . LocalRootPeers.clampToTrustable - . LocalRootPeers.fromGroups - <$> readTVar localRootsVar } - - -- - -- Part (b): capturing the major control-flow of runM: - -- - case diffusionMode of - - -- InitiatorOnly mode, run peer selection only: - InitiatorOnlyDiffusionMode -> - withConnectionManagerInitiatorOnlyMode $ \connectionManager-> do - debugStateVar <- newTVarIO $ emptyPeerSelectionState fuzzRng daConsensusMode daMinBigLedgerPeersForTrustedState - diInstallSigUSR1Handler connectionManager debugStateVar daPeerMetrics - withPeerStateActions' connectionManager $ \peerStateActions-> - withPeerSelectionActions' - (return Map.empty) - PeerSelectionActionsDiffusionMode { psPeerStateActions = peerStateActions } $ - \(ledgerPeersThread, localRootPeersProvider) peerSelectionActions-> - Async.withAsync - (peerSelectionGovernor' - dtDebugPeerSelectionInitiatorTracer - debugStateVar - peerSelectionActions) $ \governorThread -> - Async.withAsync - peerChurnGovernor' $ \churnGovernorThread -> - -- wait for any thread to fail: - snd <$> Async.waitAny - [ledgerPeersThread, localRootPeersProvider, governorThread, churnGovernorThread] - - -- InitiatorAndResponder mode, run peer selection and the server: - InitiatorAndResponderDiffusionMode -> do - inboundInfoChannel <- newInformationChannel - withConnectionManagerInitiatorAndResponderMode - inboundInfoChannel $ \connectionManager -> - -- - -- node-to-node sockets - -- - withSockets - tracer - diNtnSnocket - (\sock addr -> diNtnConfigureSocket sock (Just addr)) - (\sock addr -> diNtnConfigureSystemdSocket sock addr) - (catMaybes [daIPv4Address, daIPv6Address]) - $ \sockets addresses -> - -- - -- node-to-node server - -- - Server.with - Server.Arguments { - Server.sockets = sockets, - Server.snocket = diNtnSnocket, - Server.tracer = dtServerTracer, - Server.trTracer = dtInboundGovernorTransitionTracer, - Server.debugInboundGovernor = nullTracer, - Server.inboundGovernorTracer = dtInboundGovernorTracer, - Server.connectionLimits = daAcceptedConnectionsLimit, - Server.connectionManager = connectionManager, - Server.connectionDataFlow = diNtnDataFlow, - Server.inboundIdleTimeout = Just daProtocolIdleTimeout, - Server.inboundInfoChannel = inboundInfoChannel - } $ \inboundGovernorThread readInboundState -> do - debugStateVar <- newTVarIO $ emptyPeerSelectionState fuzzRng daConsensusMode daMinBigLedgerPeersForTrustedState - diInstallSigUSR1Handler connectionManager debugStateVar daPeerMetrics - withPeerStateActions' connectionManager $ \peerStateActions -> - withPeerSelectionActions' - (mkInboundPeersMap <$> readInboundState) - PeerSelectionActionsDiffusionMode { psPeerStateActions = peerStateActions } $ - \(ledgerPeersThread, localRootPeersProvider) peerSelectionActions -> - Async.withAsync - (peerSelectionGovernor' dtDebugPeerSelectionInitiatorResponderTracer debugStateVar peerSelectionActions) $ \governorThread -> do - -- begin, unique to InitiatorAndResponder mode: - traceWith tracer (RunServer addresses) - -- end, unique to ... - Async.withAsync peerChurnGovernor' $ \churnGovernorThread -> - -- wait for any thread to fail: - snd <$> Async.waitAny [ledgerPeersThread, localRootPeersProvider, governorThread, churnGovernorThread, inboundGovernorThread] - --- | Main entry point for data diffusion service. It allows to: --- --- * connect to upstream peers; --- * accept connection from downstream peers, if run in --- 'InitiatorAndResponderDiffusionMode'. --- * runs a local service which allows to use node-to-client protocol to obtain --- information from the running system. This is used by 'cardano-cli' or --- a wallet and a like local services. --- -run - :: Tracers RemoteAddress NodeToNodeVersion - LocalAddress NodeToClientVersion - IO - -> TracersExtra RemoteAddress NodeToNodeVersion NodeToNodeVersionData - LocalAddress NodeToClientVersion NodeToClientVersionData - IOException IO - -> Arguments IO - Socket RemoteAddress - LocalSocket LocalAddress - -> ArgumentsExtra IO - -> Applications - RemoteAddress NodeToNodeVersion NodeToNodeVersionData - LocalAddress NodeToClientVersion NodeToClientVersionData - IO a - -> ApplicationsExtra RemoteAddress IO a - -> IO Void -run tracers tracersExtra args argsExtra apps appsExtra = do - let tracer = dtDiffusionTracer tracers - -- We run two services: for /node-to-node/ and /node-to-client/. The - -- naming convention is that we use /local/ prefix for /node-to-client/ - -- related terms, as this is a local only service running over a unix - -- socket / windows named pipe. - handleJust (\e -> case fromException e :: Maybe ExitCode of - Nothing -> Just e - Just {} -> Nothing) - (\e -> traceWith tracer (DiffusionErrored e) - >> throwIO (DiffusionError e)) - $ withIOManager $ \iocp -> do - let diNtnHandshakeArguments = - HandshakeArguments { - haHandshakeTracer = dtHandshakeTracer tracers, - haHandshakeCodec = NodeToNode.nodeToNodeHandshakeCodec, - haVersionDataCodec = - cborTermVersionDataCodec - NodeToNode.nodeToNodeCodecCBORTerm, - haAcceptVersion = acceptableVersion, - haQueryVersion = queryVersion, - haTimeLimits = timeLimitsHandshake - } - diNtcHandshakeArguments = - HandshakeArguments { - haHandshakeTracer = dtLocalHandshakeTracer tracers, - haHandshakeCodec = NodeToClient.nodeToClientHandshakeCodec, - haVersionDataCodec = - cborTermVersionDataCodec - NodeToClient.nodeToClientCodecCBORTerm, - haAcceptVersion = acceptableVersion, - haQueryVersion = queryVersion, - haTimeLimits = noTimeLimitsHandshake - } - - diInstallSigUSR1Handler - :: forall mode x y ntnconn. - NodeToNodeConnectionManager mode Socket RemoteAddress - NodeToNodeVersionData NodeToNodeVersion IO x y - -> StrictTVar IO (PeerSelectionState RemoteAddress ntnconn) - -> PeerMetrics IO RemoteAddress - -> IO () -#ifdef POSIX - diInstallSigUSR1Handler = \connectionManager dbgStateVar metrics -> do - _ <- Signals.installHandler - Signals.sigUSR1 - (Signals.Catch - (do state <- atomically $ readState connectionManager - traceWith (dtConnectionManagerTracer tracersExtra) - (CM.TrState state) - ps <- readTVarIO dbgStateVar - now <- getMonotonicTime - (up, bp, lsj, am) <- atomically $ - (,,,) <$> upstreamyness metrics - <*> fetchynessBlocks metrics - <*> lpGetLedgerStateJudgement (daLedgerPeersCtx apps) - <*> Governor.readAssociationMode - (daReadUseLedgerPeers argsExtra) - (daOwnPeerSharing argsExtra) - (Governor.bootstrapPeersFlag ps) - let dbgState = makeDebugPeerSelectionState ps up bp lsj am - traceWith (dtTracePeerSelectionTracer tracersExtra) - (TraceDebugState now dbgState) - ) - ) - Nothing - return () -#else - diInstallSigUSR1Handler = \_ _ _ -> pure () -#endif - - diRng <- newStdGen - diConnStateIdSupply <- atomically $ CM.newConnStateIdSupply Proxy - runM - Interfaces { - diNtnSnocket = Snocket.socketSnocket iocp, - diNtnBearer = makeSocketBearer, - diNtnConfigureSocket = configureSocket, - diNtnConfigureSystemdSocket = - configureSystemdSocket - (SystemdSocketConfiguration `contramap` tracer), - diNtnHandshakeArguments, - diNtnAddressType = socketAddressType, - diNtnDataFlow = ntnDataFlow, - diNtnPeerSharing = peerSharing, - diNtnToPeerAddr = curry IP.toSockAddr, - - diNtcSnocket = Snocket.localSnocket iocp, - diNtcBearer = makeLocalBearer, - diNtcHandshakeArguments, - diNtcGetFileDescriptor = localSocketFileDescriptor, - - diRng, - diInstallSigUSR1Handler, - diDnsActions = ioDNSActions, - diUpdateVersionData = \versionData diffusionMode -> versionData { diffusionMode }, - diConnStateIdSupply - } - tracers tracersExtra args argsExtra apps appsExtra - - --- --- Data flow --- - --- | Node-To-Node protocol connections which negotiated --- `InitiatorAndResponderDiffusionMode` are `Duplex`. --- -ntnDataFlow :: NodeToNodeVersionData -> DataFlow -ntnDataFlow NodeToNodeVersionData { diffusionMode } = - case diffusionMode of - InitiatorAndResponderDiffusionMode -> Duplex - InitiatorOnlyDiffusionMode -> Unidirectional - - --- | All Node-To-Client protocol connections are considered 'Unidirectional'. --- -ntcDataFlow :: ntcVersionData -> DataFlow -ntcDataFlow _ = Unidirectional diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs new file mode 100644 index 00000000000..86df449bc3f --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs @@ -0,0 +1,419 @@ +-- Common things between P2P and NonP2P Diffusion modules +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Ouroboros.Network.Diffusion.Types + ( DiffusionTracer (..) + , Failure (..) + , Tracers (..) + , nullTracers + , Arguments (..) + , Applications (..) + ) where + +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Exception (Exception, SomeException) +import Control.Monad.Class.MonadTimer.SI +import Control.Tracer (Tracer, nullTracer) + +import Data.ByteString.Lazy (ByteString) +import Data.List.NonEmpty (NonEmpty) +import Data.Map (Map) +import Data.Typeable (Typeable) +import Data.Void (Void) + +import Network.Mux qualified as Mx + +import Ouroboros.Network.Mux (OuroborosApplicationWithMinimalCtx, + OuroborosBundleWithExpandedCtx) + +import Ouroboros.Network.BlockFetch +import Ouroboros.Network.PeerSharing (PeerSharingRegistry (..)) +import Ouroboros.Network.Protocol.Handshake (Versions) + +import Ouroboros.Network.ConnectionHandler +import Ouroboros.Network.ConnectionManager.Core qualified as CM +import Ouroboros.Network.ConnectionManager.State qualified as CM +import Ouroboros.Network.ConnectionManager.Types +import Ouroboros.Network.ConsensusMode +import Ouroboros.Network.ExitPolicy +import Ouroboros.Network.InboundGovernor (RemoteTransitionTrace) +import Ouroboros.Network.InboundGovernor qualified as InboundGovernor +import Ouroboros.Network.RethrowPolicy +import Ouroboros.Network.Server qualified as Server +import Ouroboros.Network.Snocket (FileDescriptor) +import Ouroboros.Network.Socket (SystemdSocketTracer) + +import Ouroboros.Network.NodeToClient qualified as NodeToClient +import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit, ConnectionId, + DiffusionMode) +import Ouroboros.Network.NodeToNode qualified as NodeToNode + +import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers) +import Ouroboros.Network.PeerSelection.Governor qualified as Governor +import Ouroboros.Network.PeerSelection.Governor.Types + (ConsensusModePeerTargets (..), DebugPeerSelection (..), + PeerSelectionCounters, PublicPeerSelectionState, + TracePeerSelection (..)) +import Ouroboros.Network.PeerSelection.LedgerPeers (TraceLedgerPeers) +import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSnapshot, + LedgerPeersConsensusInterface (..), MinBigLedgerPeersForTrustedState, + UseLedgerPeers) +import Ouroboros.Network.PeerSelection.LocalRootPeers (OutboundConnectionsState) +import Ouroboros.Network.PeerSelection.PeerAdvertise +import Ouroboros.Network.PeerSelection.PeerMetric (PeerMetrics) +import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) +import Ouroboros.Network.PeerSelection.PeerStateActions + (PeerSelectionActionsTrace) +import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint) +import Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers + (TraceLocalRootPeers) +import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers + (TracePublicRootPeers) +import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers + +-- | The 'DiffusionTracer' logs +-- +-- * diffusion initialisation messages +-- * terminal errors thrown by diffusion +-- +data DiffusionTracer ntnAddr ntcAddr + = RunServer (NonEmpty ntnAddr) + | RunLocalServer ntcAddr + | UsingSystemdSocket ntcAddr + -- Rename as 'CreateLocalSocket' + | CreateSystemdSocketForSnocketPath ntcAddr + | CreatedLocalSocket ntcAddr + | ConfiguringLocalSocket ntcAddr FileDescriptor + | ListeningLocalSocket ntcAddr FileDescriptor + | LocalSocketUp ntcAddr FileDescriptor + -- Rename as 'CreateServerSocket' + | CreatingServerSocket ntnAddr + | ConfiguringServerSocket ntnAddr + | ListeningServerSocket ntnAddr + | ServerSocketUp ntnAddr + -- Rename as 'UnsupportedLocalSocketType' + | UnsupportedLocalSystemdSocket ntnAddr + -- Remove (this is impossible case), there's no systemd on Windows + | UnsupportedReadySocketCase + | DiffusionErrored SomeException + | SystemdSocketConfiguration SystemdSocketTracer + deriving Show + +-- TODO: add a tracer for these misconfiguration +data Failure where + UnsupportedReadySocket :: Failure + UnexpectedIPv4Address :: forall ntnAddr. (Show ntnAddr, Typeable ntnAddr) => ntnAddr -> Failure + UnexpectedIPv6Address :: forall ntnAddr. (Show ntnAddr, Typeable ntnAddr) => ntnAddr -> Failure + NoSocket :: Failure + DiffusionError :: SomeException -> Failure + +deriving instance Show Failure +instance Exception Failure + +-- | Common DiffusionTracers interface between P2P and NonP2P +-- +data Tracers ntnAddr ntnVersion ntnVersionData + ntcAddr ntcVersion ntcVersionData + resolverError m = Tracers { + -- | Mux tracer + dtMuxTracer + :: Tracer m (Mx.WithBearer (ConnectionId ntnAddr) Mx.Trace) + + -- | Handshake protocol tracer + , dtHandshakeTracer + :: Tracer m (NodeToNode.HandshakeTr ntnAddr ntnVersion) + + -- + -- NodeToClient tracers + -- + + -- | Mux tracer for local clients + , dtLocalMuxTracer + :: Tracer m (Mx.WithBearer (ConnectionId ntcAddr) Mx.Trace) + + -- | Handshake protocol tracer for local clients + , dtLocalHandshakeTracer + :: Tracer m (NodeToClient.HandshakeTr ntcAddr ntcVersion) + + -- | Diffusion initialisation tracer + , dtDiffusionTracer + :: Tracer m (DiffusionTracer ntnAddr ntcAddr) + + , dtTraceLocalRootPeersTracer + :: Tracer m (TraceLocalRootPeers ntnAddr resolverError) + + , dtTracePublicRootPeersTracer + :: Tracer m TracePublicRootPeers + + -- | Ledger Peers tracer + , dtTraceLedgerPeersTracer + :: Tracer m TraceLedgerPeers + + , dtTracePeerSelectionTracer + :: Tracer m (TracePeerSelection ntnAddr) + + , dtDebugPeerSelectionInitiatorTracer + :: Tracer m (DebugPeerSelection ntnAddr) + + -- TODO: can be unified with the previous one + , dtDebugPeerSelectionInitiatorResponderTracer + :: Tracer m (DebugPeerSelection ntnAddr) + + , dtTracePeerSelectionCounters + :: Tracer m PeerSelectionCounters + + , dtTraceChurnCounters + :: Tracer m Governor.ChurnCounters + + , dtPeerSelectionActionsTracer + :: Tracer m (PeerSelectionActionsTrace ntnAddr ntnVersion) + + , dtConnectionManagerTracer + :: Tracer m (CM.Trace + ntnAddr + (ConnectionHandlerTrace + ntnVersion + ntnVersionData)) + + , dtConnectionManagerTransitionTracer + :: Tracer m (AbstractTransitionTrace CM.ConnStateId) + + , dtServerTracer + :: Tracer m (Server.Trace ntnAddr) + + , dtInboundGovernorTracer + :: Tracer m (InboundGovernor.Trace ntnAddr) + + , dtInboundGovernorTransitionTracer + :: Tracer m (RemoteTransitionTrace ntnAddr) + + -- + -- NodeToClient tracers + -- + + -- | Connection manager tracer for local clients + , dtLocalConnectionManagerTracer + :: Tracer m (CM.Trace + ntcAddr + (ConnectionHandlerTrace + ntcVersion + ntcVersionData)) + + -- | Server tracer for local clients + , dtLocalServerTracer + :: Tracer m (Server.Trace ntcAddr) + + -- | Inbound protocol governor tracer for local clients + , dtLocalInboundGovernorTracer + :: Tracer m (InboundGovernor.Trace ntcAddr) + } + + +nullTracers :: Applicative m + => Tracers ntnAddr ntnVersion ntnVersionData + ntcAddr ntcVersion ntcVersionData + resolverError m +nullTracers = Tracers { + dtMuxTracer = nullTracer + , dtHandshakeTracer = nullTracer + , dtLocalMuxTracer = nullTracer + , dtLocalHandshakeTracer = nullTracer + , dtDiffusionTracer = nullTracer + , dtTraceLocalRootPeersTracer = nullTracer + , dtTracePublicRootPeersTracer = nullTracer + , dtTraceLedgerPeersTracer = nullTracer + , dtTracePeerSelectionTracer = nullTracer + , dtTraceChurnCounters = nullTracer + , dtDebugPeerSelectionInitiatorTracer = nullTracer + , dtDebugPeerSelectionInitiatorResponderTracer = nullTracer + , dtTracePeerSelectionCounters = nullTracer + , dtPeerSelectionActionsTracer = nullTracer + , dtConnectionManagerTracer = nullTracer + , dtConnectionManagerTransitionTracer = nullTracer + , dtServerTracer = nullTracer + , dtInboundGovernorTracer = nullTracer + , dtInboundGovernorTransitionTracer = nullTracer + , dtLocalConnectionManagerTracer = nullTracer + , dtLocalServerTracer = nullTracer + , dtLocalInboundGovernorTracer = nullTracer + } + +-- | Common DiffusionArguments interface between P2P and NonP2P +-- +data Arguments m ntnFd ntnAddr ntcFd ntcAddr = Arguments { + -- | an @IPv4@ socket ready to accept connections or an @IPv4@ addresses + -- + daIPv4Address :: Maybe (Either ntnFd ntnAddr) + + -- | an @IPv6@ socket ready to accept connections or an @IPv6@ addresses + -- + , daIPv6Address :: Maybe (Either ntnFd ntnAddr) + + -- | an @AF_UNIX@ socket ready to accept connections or an @AF_UNIX@ + -- socket path + , daLocalAddress :: Maybe (Either ntcFd ntcAddr) + + -- | parameters for limiting number of accepted connections + -- + , daAcceptedConnectionsLimit :: AcceptedConnectionsLimit + + -- | run in initiator only mode + -- + , daMode :: DiffusionMode + + -- | public peer selection state + -- + -- It is created outside of diffusion, since it is needed to create some + -- apps (e.g. peer sharing). + -- + , daPublicPeerSelectionVar :: StrictTVar m (PublicPeerSelectionState ntnAddr) + + -- | selection targets for the peer governor + -- + , daPeerTargets :: ConsensusModePeerTargets + + , daReadLocalRootPeers :: STM m (LocalRootPeers.Config RelayAccessPoint) + , daReadPublicRootPeers :: STM m (Map RelayAccessPoint PeerAdvertise) + -- | When syncing up, ie. ledgerStateJudgement == TooOld, + -- when this is True we will maintain connection with many big ledger peers + -- to get a strong guarantee that when syncing up we will finish with a true + -- ledger state. When false, we will fall back on the previous algorithms + -- that leverage UseBootstrapPeers flag + , daConsensusMode :: ConsensusMode + -- | For Genesis, this sets the floor for minimum number of + -- active big ledger peers we must be connected to in order + -- to be able to signal trusted state (OutboundConnectionsState) + , daMinBigLedgerPeersForTrustedState :: MinBigLedgerPeersForTrustedState + , daReadUseBootstrapPeers :: STM m UseBootstrapPeers + -- | Depending on configuration, node may provide us with + -- a snapshot of big ledger peers taken at some slot on the chain. + -- These peers may be selected by ledgerPeersThread when requested + -- by the peer selection governor when the node is syncing up. + -- This is especially useful for Genesis consensus mode. + , daReadLedgerPeerSnapshot :: STM m (Maybe LedgerPeerSnapshot) + + -- | Peer's own PeerSharing value. + -- + -- This value comes from the node's configuration file and is static. + , daOwnPeerSharing :: PeerSharing + , daReadUseLedgerPeers :: STM m UseLedgerPeers + + -- | Timeout which starts once all responder protocols are idle. If the + -- responders stay idle for duration of the timeout, the connection will + -- be demoted, if it wasn't used by the p2p-governor it will be closed. + -- + -- Applies to 'Unidirectional' as well as 'Duplex' /node-to-node/ + -- connections. + -- + -- See 'serverProtocolIdleTimeout'. + -- + , daProtocolIdleTimeout :: DiffTime + + -- | Time for which /node-to-node/ connections are kept in + -- 'TerminatingState', it should correspond to the OS configured @TCP@ + -- @TIME_WAIT@ timeout. + -- + -- This timeout will apply to after a connection has been closed, its + -- purpose is to be resilient for delayed packets in the same way @TCP@ + -- is using @TIME_WAIT@. + -- + , daTimeWaitTimeout :: DiffTime + + -- | Churn interval between churn events in deadline mode. A small fuzz + -- is added (max 10 minutes) so that not all nodes churn at the same time. + -- + -- By default it is set to 3300 seconds. + -- + , daDeadlineChurnInterval :: DiffTime + + -- | Churn interval between churn events in bulk sync mode. A small fuzz + -- is added (max 1 minute) so that not all nodes churn at the same time. + -- + -- By default it is set to 300 seconds. + -- + , daBulkChurnInterval :: DiffTime + } + + +-- | Versioned mini-protocol bundles run on a negotiated connection. +-- +data Applications ntnAddr ntnVersion ntnVersionData + ntcAddr ntcVersion ntcVersionData + m a = + Applications { + -- | NodeToNode initiator applications for initiator only mode. + -- + -- TODO: we should accept one or the other, but not both: + -- 'daApplicationInitiatorMode', 'daApplicationInitiatorResponderMode'. + -- + -- Even in non-p2p mode we use p2p apps. + daApplicationInitiatorMode + :: Versions ntnVersion + ntnVersionData + (OuroborosBundleWithExpandedCtx + Mx.InitiatorMode ntnAddr + ByteString m a Void) + + -- | NodeToNode initiator & responder applications for bidirectional mode. + -- + , daApplicationInitiatorResponderMode + -- Peer Sharing result computation callback + :: Versions ntnVersion + ntnVersionData + (OuroborosBundleWithExpandedCtx + Mx.InitiatorResponderMode ntnAddr + ByteString m a ()) + + -- | NodeToClient responder application (server role) + -- + -- Because p2p mode does not infect local connections we we use non-p2p + -- apps. + , daLocalResponderApplication + :: Versions ntcVersion + ntcVersionData + (OuroborosApplicationWithMinimalCtx + Mx.ResponderMode ntcAddr + ByteString m Void ()) + + -- | Interface used to get peers from the current ledger. + -- + -- TODO: it should be in 'InterfaceExtra' + , daLedgerPeersCtx :: LedgerPeersConsensusInterface m + + -- | Callback provided by consensus to inform it if the node is + -- connected to only local roots or also some external peers. + -- + -- This is useful in order for the Bootstrap State Machine to + -- simply refuse to transition from TooOld to YoungEnough while + -- it only has local peers. + -- + , daUpdateOutboundConnectionsState :: OutboundConnectionsState -> STM m () + + -- | /node-to-node/ rethrow policy + -- + , daRethrowPolicy :: RethrowPolicy + + -- | /node-to-node/ return policy + -- + , daReturnPolicy :: ReturnPolicy a + + -- | /node-to-client/ rethrow policy + -- + , daLocalRethrowPolicy :: RethrowPolicy + + -- | 'PeerMetrics' used by peer selection policy (see + -- 'simplePeerSelectionPolicy') + -- + , daPeerMetrics :: PeerMetrics m ntnAddr + + -- | Used by churn-governor + -- + , daBlockFetchMode :: STM m FetchMode + + -- | Used for peer sharing protocol + -- + , daPeerSharingRegistry :: PeerSharingRegistry ntnAddr m + } diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Utils.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Utils.hs index bcab690a202..aeee341aba3 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/Utils.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/Utils.hs @@ -21,7 +21,7 @@ import Data.Typeable (Typeable) import Ouroboros.Network.Snocket (FileDescriptor, Snocket) import Ouroboros.Network.Snocket qualified as Snocket -import Ouroboros.Network.Diffusion.Common +import Ouroboros.Network.Diffusion.Types -- -- Socket utility functions diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs index 3e546d183fb..b19406f4f90 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs @@ -19,17 +19,6 @@ module Ouroboros.Network.NodeToClient , nullNetworkConnectTracers , connectTo , connectToWithMux - , NetworkServerTracers (..) - , nullNetworkServerTracers - , NetworkMutableState (..) - , newNetworkMutableState - , newNetworkMutableStateSTM - , cleanNetworkMutableState - , withServer - , NetworkClientSubcriptionTracers - , NetworkSubscriptionTracers (..) - , ClientSubscriptionParams (..) - , ncSubscriptionWorker -- * Null Protocol Peers , chainSyncPeerNull , localStateQueryPeerNull @@ -43,6 +32,7 @@ module Ouroboros.Network.NodeToClient , localSnocket , LocalSocket (..) , LocalAddress (..) + , LocalConnectionId -- * Versions , Versions (..) , versionedNodeToClientProtocols @@ -57,34 +47,19 @@ module Ouroboros.Network.NodeToClient , ConnectionId (..) , MinimalInitiatorContext (..) , ResponderContext (..) - , LocalConnectionId - , ErrorPolicies (..) - , networkErrorPolicies - , nullErrorPolicies - , ErrorPolicy (..) - , ErrorPolicyTrace (..) - , WithAddr (..) - , SuspendDecision (..) , TraceSendRecv (..) , ProtocolLimitFailure , Handshake - , LocalAddresses (..) - , SubscriptionTrace (..) , HandshakeTr ) where -import Cardano.Prelude (FatalError) - import Control.Concurrent.Async qualified as Async -import Control.Exception (ErrorCall, IOException, SomeException) +import Control.Exception (SomeException) import Control.Monad (forever) import Control.Monad.Class.MonadTimer.SI import Codec.CBOR.Term qualified as CBOR import Data.ByteString.Lazy qualified as BL -import Data.Functor (void) -import Data.Functor.Contravariant (contramap) -import Data.Functor.Identity (Identity (..)) import Data.Kind (Type) import Data.Void (Void, absurd) @@ -95,8 +70,6 @@ import Network.TypedProtocol.Stateful.Peer.Client qualified as Stateful import Ouroboros.Network.Context import Ouroboros.Network.Driver (TraceSendRecv (..)) import Ouroboros.Network.Driver.Limits (ProtocolLimitFailure (..)) -import Ouroboros.Network.Driver.Simple (DecoderFailure) -import Ouroboros.Network.ErrorPolicy import Ouroboros.Network.IOManager import Ouroboros.Network.Mux import Ouroboros.Network.NodeToClient.Version @@ -113,11 +86,6 @@ import Ouroboros.Network.Protocol.LocalTxSubmission.Client as LocalTxSubmission import Ouroboros.Network.Protocol.LocalTxSubmission.Type qualified as LocalTxSubmission import Ouroboros.Network.Snocket import Ouroboros.Network.Socket -import Ouroboros.Network.Subscription.Client (ClientSubscriptionParams (..)) -import Ouroboros.Network.Subscription.Client qualified as Subscription -import Ouroboros.Network.Subscription.Ip (SubscriptionTrace (..)) -import Ouroboros.Network.Subscription.Worker (LocalAddresses (..)) -import Ouroboros.Network.Tracers -- The Handshake tracer types are simply terrible. type HandshakeTr ntcAddr ntcVersion = @@ -310,180 +278,6 @@ connectToWithMux snocket tracers versions path k = k - --- | A specialised version of 'Ouroboros.Network.Socket.withServerNode'. --- --- Comments to 'Ouroboros.Network.NodeToNode.withServer' apply here as well. --- -withServer - :: LocalSnocket - -> NetworkServerTracers LocalAddress NodeToClientVersion - -> NetworkMutableState LocalAddress - -> LocalSocket - -> Versions NodeToClientVersion - NodeToClientVersionData - (OuroborosApplicationWithMinimalCtx - Mx.ResponderMode LocalAddress BL.ByteString IO a b) - -> ErrorPolicies - -> IO Void -withServer sn tracers networkState sd versions errPolicies = - withServerNode' - sn - makeLocalBearer - tracers - networkState - (AcceptedConnectionsLimit maxBound maxBound 0) - sd - nodeToClientHandshakeCodec - noTimeLimitsHandshake - (cborTermVersionDataCodec nodeToClientCodecCBORTerm) - (HandshakeCallbacks acceptableVersion queryVersion) - (SomeResponderApplication <$> versions) - errPolicies - (\_ async -> Async.wait async) - -type NetworkClientSubcriptionTracers - = NetworkSubscriptionTracers Identity LocalAddress NodeToClientVersion - - --- | 'ncSubscriptionWorker' which starts given application versions on each --- established connection. --- -ncSubscriptionWorker - :: forall mode x y. - ( HasInitiator mode ~ True - ) - => LocalSnocket - -> NetworkClientSubcriptionTracers - -> NetworkMutableState LocalAddress - -> ClientSubscriptionParams () - -> Versions - NodeToClientVersion - NodeToClientVersionData - (OuroborosApplicationWithMinimalCtx - mode LocalAddress BL.ByteString IO x y) - -> IO Void -ncSubscriptionWorker - sn - NetworkSubscriptionTracers - { nsSubscriptionTracer - , nsMuxTracer - , nsHandshakeTracer - , nsErrorPolicyTracer - } - networkState - subscriptionParams - versions - = Subscription.clientSubscriptionWorker - sn - (Identity `contramap` nsSubscriptionTracer) - nsErrorPolicyTracer - networkState - subscriptionParams - (void . connectToNode' - sn - makeLocalBearer - ConnectToArgs { - ctaHandshakeCodec = nodeToClientHandshakeCodec, - ctaHandshakeTimeLimits = noTimeLimitsHandshake, - ctaVersionDataCodec = cborTermVersionDataCodec nodeToClientCodecCBORTerm, - ctaConnectTracers = NetworkConnectTracers nsMuxTracer nsHandshakeTracer, - ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion - } - versions) - --- | 'ErrorPolicies' for client application. Additional rules can be added by --- means of a 'Semigroup' instance of 'ErrorPolicies'. --- --- This error policies will try to preserve `subscriptionWorker`, e.g. if the --- connect function throws an `IOException` we will suspend it for --- a 'shortDelay', and try to re-connect. --- --- This allows to recover from a situation where a node temporarily shutsdown, --- or running a client application which is subscribed two more than one node --- (possibly over network). --- -networkErrorPolicies :: ErrorPolicies -networkErrorPolicies = ErrorPolicies - { epAppErrorPolicies = [ - -- Handshake client protocol error: we either did not recognise received - -- version or we refused it. This is only for outbound connections to - -- a local node, thus we throw the exception. - ErrorPolicy - $ \(_ :: HandshakeProtocolError NodeToClientVersion) - -> Just ourBug - - -- exception thrown by `runPeerWithLimits` - -- trusted node send too much input - , ErrorPolicy - $ \(_ :: ProtocolLimitFailure) - -> Just ourBug - - -- deserialisation failure of a message from a trusted node - , ErrorPolicy - $ \(_ :: DecoderFailure) - -> Just ourBug - - , ErrorPolicy - $ \e -> case e of - Mx.UnknownMiniProtocol {} -> Just ourBug - Mx.IngressQueueOverRun {} -> Just ourBug - Mx.InitiatorOnly {} -> Just ourBug - Mx.Shutdown {} -> Just ourBug - - -- in case of bearer closed / or IOException we suspend - -- the peer for a short time - -- - -- TODO: the same notes apply as to - -- 'NodeToNode.networkErrorPolicies' - Mx.BearerClosed {} -> Just (SuspendPeer shortDelay shortDelay) - Mx.IOException {} -> Just (SuspendPeer shortDelay shortDelay) - Mx.SDUDecodeError {} -> Just ourBug - Mx.SDUReadTimeout -> Just (SuspendPeer shortDelay shortDelay) - Mx.SDUWriteTimeout -> Just (SuspendPeer shortDelay shortDelay) - - , ErrorPolicy - $ \(e :: Mx.RuntimeError) - -> case e of - Mx.ProtocolAlreadyRunning {} -> Just ourBug - Mx.UnknownProtocolInternalError {} -> Just ourBug - Mx.BlockedOnCompletionVar {} -> Just ourBug - - -- Error thrown by 'IOManager', this is fatal on Windows, and it will - -- never fire on other platofrms. - , ErrorPolicy - $ \(_ :: IOManagerError) - -> Just Throw - - -- Using 'error' throws. - , ErrorPolicy - $ \(_ :: ErrorCall) - -> Just Throw - - -- Using 'panic' throws. - , ErrorPolicy - $ \(_ :: FatalError) - -> Just Throw - ] - , epConErrorPolicies = [ - -- If an 'IOException' is thrown by the 'connect' call we suspend the - -- peer for 'shortDelay' and we will try to re-connect to it after that - -- period. - ErrorPolicy $ \(_ :: IOException) -> Just $ - SuspendPeer shortDelay shortDelay - - , ErrorPolicy - $ \(_ :: IOManagerError) - -> Just Throw - ] - } - where - ourBug :: SuspendDecision DiffTime - ourBug = Throw - - shortDelay :: DiffTime - shortDelay = 20 -- seconds - type LocalConnectionId = ConnectionId LocalAddress -- diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs index 69e0a7a34ff..2c4ffad165b 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs @@ -28,32 +28,11 @@ module Ouroboros.Network.NodeToNode , NetworkConnectTracers (..) , nullNetworkConnectTracers , connectTo - , NetworkServerTracers (..) - , nullNetworkServerTracers - , NetworkMutableState (..) , AcceptedConnectionsLimit (..) - , newNetworkMutableState - , newNetworkMutableStateSTM - , cleanNetworkMutableState - , withServer -- * P2P Governor , PeerAdvertise (..) , PeerSelectionTargets (..) -- * Subscription Workers - -- ** IP subscription worker - , IPSubscriptionTarget (..) - , NetworkIPSubscriptionTracers - , NetworkSubscriptionTracers (..) - , nullNetworkSubscriptionTracers - , SubscriptionParams (..) - , IPSubscriptionParams - , ipSubscriptionWorker - -- ** DNS subscription worker - , DnsSubscriptionTarget (..) - , DnsSubscriptionParams - , NetworkDNSSubscriptionTracers (..) - , nullNetworkDNSSubscriptionTracers - , dnsSubscriptionWorker -- ** Versions , Versions (..) , DiffusionMode (..) @@ -77,26 +56,12 @@ module Ouroboros.Network.NodeToNode , NumTxIdsToAck (..) , ProtocolLimitFailure , Handshake - , LocalAddresses (..) , Socket -- ** Exceptions , ExceptionInHandler (..) - -- ** Error Policies and Peer state - , ErrorPolicies (..) - , remoteNetworkErrorPolicy - , localNetworkErrorPolicy - , nullErrorPolicies - , ErrorPolicy (..) - , SuspendDecision (..) -- ** Traces , AcceptConnectionsPolicyTrace (..) , TraceSendRecv (..) - , SubscriptionTrace (..) - , DnsTrace (..) - , ErrorPolicyTrace (..) - , WithIPList (..) - , WithDomainName (..) - , WithAddr (..) , HandshakeTr -- * For Consensus ThreadNet Tests , chainSyncMiniProtocolNum @@ -106,29 +71,20 @@ module Ouroboros.Network.NodeToNode , peerSharingMiniProtocolNum ) where -import Control.Concurrent.Async qualified as Async -import Control.Exception (IOException, SomeException) -import Control.Monad.Class.MonadTime.SI (DiffTime) +import Control.Exception (SomeException) -import Codec.CBOR.Read qualified as CBOR import Codec.CBOR.Term qualified as CBOR import Data.ByteString.Lazy qualified as BL -import Data.Functor (void) -import Data.Void (Void) import Data.Word import Network.Mux qualified as Mx import Network.Socket (Socket, StructLinger (..)) import Network.Socket qualified as Socket -import Ouroboros.Network.BlockFetch.Client (BlockFetchProtocolFailure) import Ouroboros.Network.ConnectionManager.Types (ExceptionInHandler (..)) import Ouroboros.Network.Context import Ouroboros.Network.ControlMessage (ControlMessage (..)) import Ouroboros.Network.Driver (TraceSendRecv (..)) import Ouroboros.Network.Driver.Limits (ProtocolLimitFailure (..)) -import Ouroboros.Network.Driver.Simple (DecoderFailure) -import Ouroboros.Network.ErrorPolicy -import Ouroboros.Network.IOManager import Ouroboros.Network.Mux import Ouroboros.Network.NodeToNode.Version import Ouroboros.Network.PeerSelection.Governor.Types @@ -139,20 +95,9 @@ import Ouroboros.Network.Protocol.Handshake.Codec import Ouroboros.Network.Protocol.Handshake.Type import Ouroboros.Network.Protocol.Handshake.Version hiding (Accept) import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToAck (..)) +import Ouroboros.Network.Server.RateLimiting import Ouroboros.Network.Snocket import Ouroboros.Network.Socket -import Ouroboros.Network.Subscription.Dns (DnsSubscriptionParams, - DnsSubscriptionTarget (..), DnsTrace (..), WithDomainName (..)) -import Ouroboros.Network.Subscription.Dns qualified as Subscription -import Ouroboros.Network.Subscription.Ip (IPSubscriptionParams, - IPSubscriptionTarget (..), SubscriptionParams (..), - SubscriptionTrace (..), WithIPList (..)) -import Ouroboros.Network.Subscription.Ip qualified as Subscription -import Ouroboros.Network.Subscription.Worker (LocalAddresses (..), - SubscriberError) -import Ouroboros.Network.Tracers -import Ouroboros.Network.TxSubmission.Inbound qualified as TxInbound -import Ouroboros.Network.TxSubmission.Outbound qualified as TxOutbound import Ouroboros.Network.Util.ShowProxy (ShowProxy, showProxy) @@ -470,283 +415,6 @@ connectTo sn tr = sl_linger = 0 }) --- | A specialised version of @'Ouroboros.Network.Socket.withServerNode'@. --- It forks a thread which runs an accept loop (server thread): --- --- * when the server thread throws an exception the main thread rethrows --- it (by 'Async.wait') --- * when an async exception is thrown to kill the main thread the server thread --- will be cancelled as well (by 'withAsync') --- -withServer - :: SocketSnocket - -> NetworkServerTracers Socket.SockAddr NodeToNodeVersion - -> NetworkMutableState Socket.SockAddr - -> AcceptedConnectionsLimit - -> Socket.Socket - -- ^ a configured socket to be used be the server. The server will call - -- `bind` and `listen` methods but it will not set any socket or tcp options - -- on it. - -> Versions NodeToNodeVersion - NodeToNodeVersionData - (OuroborosApplicationWithMinimalCtx - Mx.ResponderMode Socket.SockAddr BL.ByteString IO a b) - -> ErrorPolicies - -> IO Void -withServer sn tracers networkState acceptedConnectionsLimit sd versions errPolicies = - withServerNode' - sn - makeSocketBearer - tracers - networkState - acceptedConnectionsLimit - sd - nodeToNodeHandshakeCodec - timeLimitsHandshake - (cborTermVersionDataCodec nodeToNodeCodecCBORTerm) - (HandshakeCallbacks acceptableVersion queryVersion) - (SomeResponderApplication <$> versions) - errPolicies - (\_ async -> Async.wait async) - - --- | 'ipSubscriptionWorker' which starts given application versions on each --- established connection. --- -ipSubscriptionWorker - :: forall mode x y. - ( HasInitiator mode ~ True ) - => SocketSnocket - -> NetworkIPSubscriptionTracers Socket.SockAddr NodeToNodeVersion - -> NetworkMutableState Socket.SockAddr - -> IPSubscriptionParams () - -> Versions - NodeToNodeVersion - NodeToNodeVersionData - (OuroborosApplicationWithMinimalCtx - mode Socket.SockAddr BL.ByteString IO x y) - -> IO Void -ipSubscriptionWorker - sn - NetworkSubscriptionTracers - { nsSubscriptionTracer - , nsMuxTracer - , nsHandshakeTracer - , nsErrorPolicyTracer - } - networkState - subscriptionParams - versions - = Subscription.ipSubscriptionWorker - sn - nsSubscriptionTracer - nsErrorPolicyTracer - networkState - subscriptionParams - (void . connectToNode' - sn - makeSocketBearer - ConnectToArgs { - ctaHandshakeCodec = nodeToNodeHandshakeCodec, - ctaHandshakeTimeLimits = timeLimitsHandshake, - ctaVersionDataCodec = cborTermVersionDataCodec nodeToNodeCodecCBORTerm, - ctaConnectTracers = NetworkConnectTracers nsMuxTracer nsHandshakeTracer, - ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion - } - versions) - - --- | 'dnsSubscriptionWorker' which starts given application versions on each --- established connection. --- -dnsSubscriptionWorker - :: forall mode x y. - ( HasInitiator mode ~ True ) - => SocketSnocket - -> NetworkDNSSubscriptionTracers NodeToNodeVersion Socket.SockAddr - -> NetworkMutableState Socket.SockAddr - -> DnsSubscriptionParams () - -> Versions - NodeToNodeVersion - NodeToNodeVersionData - (OuroborosApplicationWithMinimalCtx - mode Socket.SockAddr BL.ByteString IO x y) - -> IO Void -dnsSubscriptionWorker - sn - NetworkDNSSubscriptionTracers - { ndstSubscriptionTracer - , ndstDnsTracer - , ndstMuxTracer - , ndstHandshakeTracer - , ndstErrorPolicyTracer - } - networkState - subscriptionParams - versions = - Subscription.dnsSubscriptionWorker - sn - ndstSubscriptionTracer - ndstDnsTracer - ndstErrorPolicyTracer - networkState - subscriptionParams - (void . connectToNode' - sn - makeSocketBearer - ConnectToArgs { - ctaHandshakeCodec = nodeToNodeHandshakeCodec, - ctaHandshakeTimeLimits = timeLimitsHandshake, - ctaVersionDataCodec = cborTermVersionDataCodec nodeToNodeCodecCBORTerm, - ctaConnectTracers = NetworkConnectTracers ndstMuxTracer ndstHandshakeTracer, - ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion - } - versions) - - --- | A minimal error policy for remote peers, which only handles exceptions --- raised by `ouroboros-network`. --- -remoteNetworkErrorPolicy :: ErrorPolicies -remoteNetworkErrorPolicy = ErrorPolicies { - epAppErrorPolicies = [ - -- Handshake client protocol error: we either did not recognise received - -- version or we refused it. This is only for outbound connections, - -- thus we suspend the consumer. - ErrorPolicy - $ \(_ :: HandshakeProtocolError NodeToNodeVersion) - -> Just misconfiguredPeer - - -- deserialisation failure; this means that the remote peer is either - -- buggy, adversarial, or the connection return garbage. In the last - -- case it's also good to shutdown both the consumer and the - -- producer, as it's likely that the other side of the connection - -- will return garbage as well. - , ErrorPolicy - $ \(_ :: DecoderFailure) - -> Just theyBuggyOrEvil - - , ErrorPolicy - $ \(msg :: ProtocolLimitFailure) - -> case msg of - ExceededSizeLimit{} -> Just theyBuggyOrEvil - ExceededTimeLimit{} -> Just (SuspendConsumer shortDelay) - - -- the connection was unexpectedly closed, we suspend the peer for - -- a 'shortDelay' - , ErrorPolicy - $ \e -> case e of - Mx.UnknownMiniProtocol {} -> Just theyBuggyOrEvil - Mx.IngressQueueOverRun {} -> Just theyBuggyOrEvil - Mx.InitiatorOnly {} -> Just theyBuggyOrEvil - - -- in case of bearer closed / or IOException we suspend - -- the peer for a short time - -- - -- TODO: an exponential backoff would be nicer than a fixed 20s - -- TODO: right now we cannot suspend just the - -- 'responder'. If a 'responder' throws 'MuxError' we - -- might not want to shutdown the consumer (which is - -- using different connection), as we do below: - Mx.BearerClosed {} -> Just (SuspendPeer veryShortDelay shortDelay) - Mx.IOException {} -> Just (SuspendPeer veryShortDelay shortDelay) - Mx.SDUDecodeError {} -> Just theyBuggyOrEvil - Mx.SDUReadTimeout -> Just (SuspendPeer veryShortDelay shortDelay) - Mx.SDUWriteTimeout -> Just (SuspendPeer veryShortDelay shortDelay) - Mx.Shutdown {} -> Just (SuspendPeer veryShortDelay shortDelay) - - , ErrorPolicy - $ \(e :: Mx.RuntimeError) - -> case e of - Mx.ProtocolAlreadyRunning {} -> Just (SuspendPeer shortDelay shortDelay) - Mx.UnknownProtocolInternalError {} -> Just Throw - Mx.BlockedOnCompletionVar {} -> Just (SuspendPeer shortDelay shortDelay) - - -- Error policy for TxSubmission protocol: outbound side (client role) - , ErrorPolicy - $ \(_ :: TxOutbound.TxSubmissionProtocolError) - -> Just theyBuggyOrEvil - - -- Error policy for TxSubmission protocol: inbound side (server role) - , ErrorPolicy - $ \(_ :: TxInbound.TxSubmissionProtocolError) - -> Just theyBuggyOrEvil - - -- Error policy for BlockFetch protocol: consumer side (client role) - , ErrorPolicy - $ \(_ :: BlockFetchProtocolFailure) - -> Just theyBuggyOrEvil - - -- Error thrown by 'IOManager', this is fatal on Windows, and it will - -- never fire on other platforms. - , ErrorPolicy - $ \(_ :: IOManagerError) - -> Just Throw - ], - - -- Exception raised during connect; suspend connecting to that peer for - -- a 'shortDelay' - epConErrorPolicies = [ - ErrorPolicy $ \(_ :: IOException) -> Just $ - SuspendConsumer shortDelay - - , ErrorPolicy - $ \(_ :: IOManagerError) - -> Just Throw - , ErrorPolicy - -- Multiple connection attempts are run in parallel and the last to - -- finish are cancelled. There may be nothing wrong with the peer, - -- it could just be slow to respond. - $ \(_ :: SubscriberError) - -> Just (SuspendConsumer veryShortDelay) - ] - } - where - theyBuggyOrEvil :: SuspendDecision DiffTime - theyBuggyOrEvil = SuspendPeer defaultDelay defaultDelay - - misconfiguredPeer :: SuspendDecision DiffTime - misconfiguredPeer = SuspendConsumer defaultDelay - - defaultDelay :: DiffTime - defaultDelay = 200 -- seconds - - shortDelay :: DiffTime - shortDelay = 20 -- seconds - - veryShortDelay :: DiffTime - veryShortDelay = 1 -- seconds - --- | Error policy for local clients. This is equivalent to --- 'nullErrorPolicies', but explicit in the errors which can be caught. --- --- We are very permissive here, and very strict in the --- `NodeToClient.networkErrorPolicy`. After any failure the client will be --- killed and not penalised by this policy. This allows to restart the local --- client without a delay. --- -localNetworkErrorPolicy :: ErrorPolicies -localNetworkErrorPolicy = ErrorPolicies { - epAppErrorPolicies = [ - -- exception thrown by `runPeerWithLimits` - ErrorPolicy - $ \(_ :: ProtocolLimitFailure) - -> Nothing - - -- deserialisation failure - , ErrorPolicy - $ \(_ :: CBOR.DeserialiseFailure) -> Nothing - - -- the connection was unexpectedly closed, we suspend the peer for - -- a 'shortDelay' - , ErrorPolicy - $ \(_ :: Mx.Error) -> Nothing - ], - - -- The node never connects to a local client - epConErrorPolicies = [] - } - type RemoteAddress = Socket.SockAddr instance ShowProxy RemoteAddress where diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor.hs index 8d38e98c077..02c2b2641bb 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor.hs @@ -27,6 +27,7 @@ module Ouroboros.Network.PeerSelection.Governor , TracePeerSelection (..) , ChurnAction (..) , DebugPeerSelection (..) + , makeDebugPeerSelectionState , AssociationMode (..) , readAssociationMode , DebugPeerSelectionState (..) diff --git a/ouroboros-network/src/Ouroboros/Network/Tracers.hs b/ouroboros-network/src/Ouroboros/Network/Tracers.hs deleted file mode 100644 index 6c1b0c73cb2..00000000000 --- a/ouroboros-network/src/Ouroboros/Network/Tracers.hs +++ /dev/null @@ -1,81 +0,0 @@ -module Ouroboros.Network.Tracers - ( NetworkSubscriptionTracers (..) - , NetworkIPSubscriptionTracers - , nullNetworkSubscriptionTracers - , NetworkDNSSubscriptionTracers (..) - , nullNetworkDNSSubscriptionTracers - ) where - -import Codec.CBOR.Term qualified as CBOR -import Control.Tracer (Tracer, nullTracer) - -import Network.Mux.Trace qualified as Mx - -import Ouroboros.Network.Driver (TraceSendRecv) -import Ouroboros.Network.ErrorPolicy -import Ouroboros.Network.Protocol.Handshake.Type -import Ouroboros.Network.Socket (ConnectionId) -import Ouroboros.Network.Subscription.Dns -import Ouroboros.Network.Subscription.Ip - --- | IP subscription tracers. --- -data NetworkSubscriptionTracers withIPList addr vNumber = NetworkSubscriptionTracers { - nsMuxTracer :: Tracer IO (Mx.WithBearer (ConnectionId addr) Mx.Trace), - -- ^ low level mux-network tracer, which logs mux sdu (send and received) - -- and other low level multiplexing events. - nsHandshakeTracer :: Tracer IO (Mx.WithBearer (ConnectionId addr) - (TraceSendRecv (Handshake vNumber CBOR.Term))), - -- ^ handshake protocol tracer; it is important for analysing version - -- negotation mismatches. - nsErrorPolicyTracer :: Tracer IO (WithAddr addr ErrorPolicyTrace), - -- ^ error policy tracer; must not be 'nullTracer', otherwise all the - -- exceptions which are not matched by any error policy will be caught - -- and not logged or rethrown. - nsSubscriptionTracer :: Tracer IO (withIPList (SubscriptionTrace addr)) - -- ^ subscription tracers; it is infrequent it should not be 'nullTracer' - -- by default. - } - -type NetworkIPSubscriptionTracers addr vNumber = - NetworkSubscriptionTracers WithIPList addr vNumber - -nullNetworkSubscriptionTracers :: NetworkSubscriptionTracers withIPList addr vNumber -nullNetworkSubscriptionTracers = NetworkSubscriptionTracers { - nsMuxTracer = nullTracer, - nsHandshakeTracer = nullTracer, - nsErrorPolicyTracer = nullTracer, - nsSubscriptionTracer = nullTracer - } - --- | DNS subscription tracers. --- -data NetworkDNSSubscriptionTracers vNumber addr = NetworkDNSSubscriptionTracers { - ndstMuxTracer :: Tracer IO (Mx.WithBearer (ConnectionId addr) Mx.Trace), - -- ^ low level mux-network tracer, which logs mux sdu (send and received) - -- and other low level multiplexing events. - ndstHandshakeTracer :: Tracer IO (Mx.WithBearer (ConnectionId addr) - (TraceSendRecv (Handshake vNumber CBOR.Term))), - -- ^ handshake protocol tracer; it is important for analysing version - -- negotation mismatches. - ndstErrorPolicyTracer :: Tracer IO (WithAddr addr ErrorPolicyTrace), - -- ^ error policy tracer; must not be 'nullTracer', otherwise all the - -- exceptions which are not matched by any error policy will be caught - -- and not logged or rethrown. - ndstSubscriptionTracer :: Tracer IO (WithDomainName (SubscriptionTrace addr)), - -- ^ subscription tracer; it is infrequent it should not be 'nullTracer' - -- by default. - ndstDnsTracer :: Tracer IO (WithDomainName DnsTrace) - -- ^ dns resolver tracer; it is infrequent it should not be 'nullTracer' - -- by default. - - } - -nullNetworkDNSSubscriptionTracers :: NetworkDNSSubscriptionTracers vNumber peerid -nullNetworkDNSSubscriptionTracers = NetworkDNSSubscriptionTracers { - ndstMuxTracer = nullTracer, - ndstHandshakeTracer = nullTracer, - ndstErrorPolicyTracer = nullTracer, - ndstSubscriptionTracer = nullTracer, - ndstDnsTracer = nullTracer - } diff --git a/scripts/prologue b/scripts/prologue index 7d195ab4134..6cc8373691e 100644 --- a/scripts/prologue +++ b/scripts/prologue @@ -32,8 +32,7 @@ This site contains Haskell documentation of __Ouroboros-Network__ ouroboros protocols, but build a solid foundation for the networking library. Among others, it includes * __[Inbound Governor](ouroboros-network-framework/Ouroboros-Network-InboundGovernor.html)__ - * __[Server P2P](ouroboros-network-framework/Ouroboros-Network-Server2.html)__ - * __[Server NonP2P](ouroboros-network-framework/Ouroboros-Network-Server-Socket.html)__ + * __[Server P2P](ouroboros-network-framework/Ouroboros-Network-Server.html)__ * __[Socket](ouroboros-network-framework/Ouroboros-Network-Socket.html)__ * __[Snocket](ouroboros-network-framework/Ouroboros-Network-Snocket.html)__ * __[Simulated Snocket](ouroboros-network-framework/Simulation-Network-Snocket.html)__