Use exponential distribution for P2P session timeouts

src/Chainweb/Time.hs

@@ -326,10 +326,8 @@ secondsToTimeSpan :: Num a => Seconds -> TimeSpan a
 secondsToTimeSpan (Seconds s) = scaleTimeSpan s second
 {-# INLINE secondsToTimeSpan #-}
 
--- | Assumes that the `TimeSpan` contains milliseconds.
---
 timeSpanToSeconds :: Integral a => TimeSpan a -> Seconds
-timeSpanToSeconds (TimeSpan ms) = Seconds . int $ ms `div` 1000000
+timeSpanToSeconds (TimeSpan us) = Seconds . int $ us `div` 1000000
 {-# INLINE timeSpanToSeconds #-}
 
 secondsToText :: Seconds -> T.Text
@@ -361,10 +359,8 @@ microsToTimeSpan :: Num a => Micros -> TimeSpan a
 microsToTimeSpan (Micros us) = scaleTimeSpan us microsecond
 {-# INLINE microsToTimeSpan #-}
 
--- | Assumes that the `TimeSpan` contains milliseconds.
---
 timeSpanToMicros :: Integral a => TimeSpan a -> Micros
-timeSpanToMicros (TimeSpan ms) = Micros . int $ ms * 1000
+timeSpanToMicros (TimeSpan us) = Micros . int $ us
 {-# INLINE timeSpanToMicros #-}
 
 microsToText :: Micros -> T.Text

src/P2P/Node.hs

@@ -3,8 +3,10 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -585,26 +587,43 @@ newSession conf node = do
             let env = peerClientEnv node newPeerInfo
             (info, newSes) <- mask $ \restore -> do
                 now <- getCurrentTimeIntegral
-                t <- R.randomRIO
-                    ( round (0.9 * timeoutMs)
-                    , round (1.1 * timeoutMs)
-                    )
-                !newSes <- async $ restore $ timeout t
+                t <- sessionTimeout $ secondsToTimeSpan $ _p2pConfigSessionTimeout conf
+                !newSes <- async $ restore $ timeout (int $ timeSpanToMicros t)
                     $ _p2pNodeClientSession node (loggFun node) env newPeerInfo
                 incrementActiveSessionCount peerDb newPeerInfo
                 !info <- atomically $ addSession node newPeerInfo newSes now
                 return (info, newSes)
             logg node Debug $ "Started peer session " <> showSessionId newPeerInfo newSes
             loggFun node Info $ JsonLog info
   where
-    TimeSpan timeoutMs = secondsToTimeSpan @Double (_p2pConfigSessionTimeout conf)
     peerDb = _p2pNodePeerDb node
 
     syncFromPeer_ pinfo
         | _p2pConfigPrivate conf = return True
         | _p2pNodeDoPeerSync node = syncFromPeer node pinfo
         | otherwise = return True
 
+-- | (Roughly) exponentially distributed timespans with the given expectation
+-- within the range of a a tenth of the expectation and ten times the
+-- expectation.
+--
+-- The expected value of the actual distribution gets increasinly imprecise
+-- as the input value gets smaller, because a minimum result of 5 seconds
+-- is implemented. Input values of less than 30s should be avoided.
+--
+sessionTimeout :: TimeSpan Int -> IO (TimeSpan Int)
+sessionTimeout expected = do
+    x <- exponential (1 / us) :: IO Double
+    return $! microsToTimeSpan $ round $ max lower $ min upper x
+  where
+    us = int $ timeSpanToMicros expected
+    lower = max 5_000_000 (us / 10) -- at least 5 seconds
+    upper = us * 10
+
+    exponential rate = do
+        !x <- R.getStdRandom (R.randomR (0, 1))
+        return $! - log x / rate
+
 -- | Monitor and garbage collect sessions
 --
 awaitSessions :: P2pNode -> IO ()

test/Chainweb/Test/Roundtrips.hs

@@ -19,6 +19,7 @@ import Crypto.Hash.Algorithms
 import Data.Aeson
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.HashMap.Strict as HM
+import Data.Int
 import qualified Data.Text as T
 
 import Test.QuickCheck
@@ -68,6 +69,7 @@ tests = testGroup "roundtrip tests"
     , hasTextRepresentationTests
     , jsonRoundtripTests
     , jsonKeyRoundtripTests
+    , timeSpanTests
     ]
 
 -- -------------------------------------------------------------------------- --
@@ -196,6 +198,7 @@ jsonTestCases f =
     [ testProperty "Time Micros" $ f @(Time Micros)
     , testProperty "TimeSpan Micros" $ f @(TimeSpan Micros)
     , testProperty "Seconds" $ f @Seconds
+    , testProperty "Micros" $ f @Micros
     , testProperty "ChainId" $ f @ChainId
     , testProperty "ChainwebVersion" $ f @ChainwebVersion
     , testProperty "Nonce" $ f @Nonce
@@ -344,6 +347,7 @@ hasTextRepresentationTests = testGroup "HasTextRepresentation roundtrips"
     , testProperty "ChainId" $ prop_iso' @_ @ChainId fromText toText
     , testProperty "BlockHash" $ prop_iso' @_ @BlockHash fromText toText
     , testProperty "Seconds" $ prop_iso' @_ @Seconds fromText toText
+    , testProperty "Micros" $ prop_iso' @_ @Micros fromText toText
     , testProperty "Hostname" $ prop_iso' @_ @Hostname fromText toText
     , testProperty "Port" $ prop_iso' @_ @Port fromText toText
     , testProperty "HostAddress" $ prop_iso' @_ @HostAddress fromText toText
@@ -357,3 +361,21 @@ hasTextRepresentationTests = testGroup "HasTextRepresentation roundtrips"
     , testProperty "ChainDatabaseGcConfig" $ prop_iso' @_ @ChainDatabaseGcConfig fromText toText
     , testProperty "MerkleRootType" $ prop_iso' @_ @MerkleRootType fromText toText
     ]
+
+-- -------------------------------------------------------------------------- --
+-- Time
+
+timeSpanTests :: TestTree
+timeSpanTests = testGroup "TimeSpan roundtrips"
+    [ testProperty "timeSpanToMicros Int" $ prop_iso @(TimeSpan Int) microsToTimeSpan timeSpanToMicros
+    , testProperty "timeSpanToMicros Int64" $ prop_iso @(TimeSpan Int64) microsToTimeSpan timeSpanToMicros
+    , testProperty "timeSpanToMicros Micros" $ prop_iso @(TimeSpan Micros) microsToTimeSpan timeSpanToMicros
+
+    , testProperty "microsToTimeSpan Int" $ prop_iso @_ @(TimeSpan Int) timeSpanToMicros microsToTimeSpan
+    , testProperty "microsToTimeSpan Int64" $ prop_iso @_ @(TimeSpan Int64) timeSpanToMicros microsToTimeSpan
+    , testProperty "microsToTimeSpan Micros" $ prop_iso @_ @(TimeSpan Micros) timeSpanToMicros microsToTimeSpan
+
+    , testProperty "secondsToTimeSpan Int" $ prop_iso @_ @(TimeSpan Int) timeSpanToSeconds secondsToTimeSpan
+    , testProperty "secondsToTimeSpan Int64" $ prop_iso @_ @(TimeSpan Int64) timeSpanToSeconds secondsToTimeSpan
+    , testProperty "secondsToTimeSpan Seconds" $ prop_iso @_ @(TimeSpan Micros) timeSpanToSeconds secondsToTimeSpan
+    ]