use TCP keep-alive instead of SMP protocol PING (#330)
* use TCP keep-alive instead of SMP protocol PING * update header files * use CInt * use Int again * use network-3.1.2.7 * use https in cabal.project * confitional keep-alive parameters to work on mac * pass keep-alive opts via client/agent options * remove space
This commit is contained in:
parent
5c6ec96d64
commit
a37b24a8c2
|
@ -2,5 +2,5 @@ packages: .
|
||||||
|
|
||||||
source-repository-package
|
source-repository-package
|
||||||
type: git
|
type: git
|
||||||
location: git://github.com/simplex-chat/aeson.git
|
location: https://github.com/simplex-chat/aeson.git
|
||||||
tag: 3eb66f9a68f103b5f1489382aad89f5712a64db7
|
tag: 3eb66f9a68f103b5f1489382aad89f5712a64db7
|
||||||
|
|
|
@ -45,7 +45,7 @@ dependencies:
|
||||||
- iso8601-time == 0.1.*
|
- iso8601-time == 0.1.*
|
||||||
- memory == 0.15.*
|
- memory == 0.15.*
|
||||||
- mtl == 2.2.*
|
- mtl == 2.2.*
|
||||||
- network == 3.1.*
|
- network == 3.1.2.*
|
||||||
- network-transport == 0.5.*
|
- network-transport == 0.5.*
|
||||||
- QuickCheck == 2.14.*
|
- QuickCheck == 2.14.*
|
||||||
- random >= 1.1 && < 1.3
|
- random >= 1.1 && < 1.3
|
||||||
|
|
|
@ -57,6 +57,7 @@ library
|
||||||
Simplex.Messaging.Server.StoreLog
|
Simplex.Messaging.Server.StoreLog
|
||||||
Simplex.Messaging.Transport
|
Simplex.Messaging.Transport
|
||||||
Simplex.Messaging.Transport.Client
|
Simplex.Messaging.Transport.Client
|
||||||
|
Simplex.Messaging.Transport.KeepAlive
|
||||||
Simplex.Messaging.Transport.Server
|
Simplex.Messaging.Transport.Server
|
||||||
Simplex.Messaging.Transport.WebSockets
|
Simplex.Messaging.Transport.WebSockets
|
||||||
Simplex.Messaging.Util
|
Simplex.Messaging.Util
|
||||||
|
@ -91,7 +92,7 @@ library
|
||||||
, iso8601-time ==0.1.*
|
, iso8601-time ==0.1.*
|
||||||
, memory ==0.15.*
|
, memory ==0.15.*
|
||||||
, mtl ==2.2.*
|
, mtl ==2.2.*
|
||||||
, network ==3.1.*
|
, network ==3.1.2.*
|
||||||
, network-transport ==0.5.*
|
, network-transport ==0.5.*
|
||||||
, random >=1.1 && <1.3
|
, random >=1.1 && <1.3
|
||||||
, simple-logger ==0.1.*
|
, simple-logger ==0.1.*
|
||||||
|
@ -142,7 +143,7 @@ executable smp-agent
|
||||||
, iso8601-time ==0.1.*
|
, iso8601-time ==0.1.*
|
||||||
, memory ==0.15.*
|
, memory ==0.15.*
|
||||||
, mtl ==2.2.*
|
, mtl ==2.2.*
|
||||||
, network ==3.1.*
|
, network ==3.1.2.*
|
||||||
, network-transport ==0.5.*
|
, network-transport ==0.5.*
|
||||||
, random >=1.1 && <1.3
|
, random >=1.1 && <1.3
|
||||||
, simple-logger ==0.1.*
|
, simple-logger ==0.1.*
|
||||||
|
@ -195,7 +196,7 @@ executable smp-server
|
||||||
, iso8601-time ==0.1.*
|
, iso8601-time ==0.1.*
|
||||||
, memory ==0.15.*
|
, memory ==0.15.*
|
||||||
, mtl ==2.2.*
|
, mtl ==2.2.*
|
||||||
, network ==3.1.*
|
, network ==3.1.2.*
|
||||||
, network-transport ==0.5.*
|
, network-transport ==0.5.*
|
||||||
, optparse-applicative >=0.15 && <0.17
|
, optparse-applicative >=0.15 && <0.17
|
||||||
, process ==1.6.*
|
, process ==1.6.*
|
||||||
|
@ -264,7 +265,7 @@ test-suite smp-server-test
|
||||||
, iso8601-time ==0.1.*
|
, iso8601-time ==0.1.*
|
||||||
, memory ==0.15.*
|
, memory ==0.15.*
|
||||||
, mtl ==2.2.*
|
, mtl ==2.2.*
|
||||||
, network ==3.1.*
|
, network ==3.1.2.*
|
||||||
, network-transport ==0.5.*
|
, network-transport ==0.5.*
|
||||||
, random >=1.1 && <1.3
|
, random >=1.1 && <1.3
|
||||||
, simple-logger ==0.1.*
|
, simple-logger ==0.1.*
|
||||||
|
|
|
@ -65,6 +65,7 @@ import qualified Simplex.Messaging.Crypto as C
|
||||||
import Simplex.Messaging.Protocol
|
import Simplex.Messaging.Protocol
|
||||||
import Simplex.Messaging.Transport (ATransport (..), THandle (..), TLS, TProxy, Transport (..), TransportError, clientHandshake)
|
import Simplex.Messaging.Transport (ATransport (..), THandle (..), TLS, TProxy, Transport (..), TransportError, clientHandshake)
|
||||||
import Simplex.Messaging.Transport.Client (runTransportClient)
|
import Simplex.Messaging.Transport.Client (runTransportClient)
|
||||||
|
import Simplex.Messaging.Transport.KeepAlive
|
||||||
import Simplex.Messaging.Transport.WebSockets (WS)
|
import Simplex.Messaging.Transport.WebSockets (WS)
|
||||||
import Simplex.Messaging.Util (bshow, liftError, raceAny_)
|
import Simplex.Messaging.Util (bshow, liftError, raceAny_)
|
||||||
import System.Timeout (timeout)
|
import System.Timeout (timeout)
|
||||||
|
@ -99,6 +100,8 @@ data SMPClientConfig = SMPClientConfig
|
||||||
defaultTransport :: (ServiceName, ATransport),
|
defaultTransport :: (ServiceName, ATransport),
|
||||||
-- | timeout of TCP commands (microseconds)
|
-- | timeout of TCP commands (microseconds)
|
||||||
tcpTimeout :: Int,
|
tcpTimeout :: Int,
|
||||||
|
-- | TCP keep-alive options, Nothing to skip enabling keep-alive
|
||||||
|
tcpKeepAlive :: Maybe KeepAliveOpts,
|
||||||
-- | period for SMP ping commands (microseconds)
|
-- | period for SMP ping commands (microseconds)
|
||||||
smpPing :: Int
|
smpPing :: Int
|
||||||
}
|
}
|
||||||
|
@ -110,7 +113,8 @@ smpDefaultConfig =
|
||||||
{ qSize = 64,
|
{ qSize = 64,
|
||||||
defaultTransport = ("5223", transport @TLS),
|
defaultTransport = ("5223", transport @TLS),
|
||||||
tcpTimeout = 4_000_000,
|
tcpTimeout = 4_000_000,
|
||||||
smpPing = 30_000_000
|
tcpKeepAlive = Just defaultKeepAliveOpts,
|
||||||
|
smpPing = 1_200_000_000 -- 20min
|
||||||
}
|
}
|
||||||
|
|
||||||
data Request = Request
|
data Request = Request
|
||||||
|
@ -126,7 +130,7 @@ type Response = Either SMPClientError BrokerMsg
|
||||||
-- A single queue can be used for multiple 'SMPClient' instances,
|
-- A single queue can be used for multiple 'SMPClient' instances,
|
||||||
-- as 'SMPServerTransmission' includes server information.
|
-- as 'SMPServerTransmission' includes server information.
|
||||||
getSMPClient :: SMPServer -> SMPClientConfig -> TBQueue SMPServerTransmission -> IO () -> IO (Either SMPClientError SMPClient)
|
getSMPClient :: SMPServer -> SMPClientConfig -> TBQueue SMPServerTransmission -> IO () -> IO (Either SMPClientError SMPClient)
|
||||||
getSMPClient smpServer cfg@SMPClientConfig {qSize, tcpTimeout, smpPing} msgQ disconnected =
|
getSMPClient smpServer cfg@SMPClientConfig {qSize, tcpTimeout, tcpKeepAlive, smpPing} msgQ disconnected =
|
||||||
atomically mkSMPClient >>= runClient useTransport
|
atomically mkSMPClient >>= runClient useTransport
|
||||||
where
|
where
|
||||||
mkSMPClient :: STM SMPClient
|
mkSMPClient :: STM SMPClient
|
||||||
|
@ -155,7 +159,7 @@ getSMPClient smpServer cfg@SMPClientConfig {qSize, tcpTimeout, smpPing} msgQ dis
|
||||||
thVar <- newEmptyTMVarIO
|
thVar <- newEmptyTMVarIO
|
||||||
action <-
|
action <-
|
||||||
async $
|
async $
|
||||||
runTransportClient (host smpServer) port' (keyHash smpServer) (client t c thVar)
|
runTransportClient (host smpServer) port' (keyHash smpServer) tcpKeepAlive (client t c thVar)
|
||||||
`finally` atomically (putTMVar thVar $ Left SMPNetworkError)
|
`finally` atomically (putTMVar thVar $ Left SMPNetworkError)
|
||||||
th_ <- tcpTimeout `timeout` atomically (takeTMVar thVar)
|
th_ <- tcpTimeout `timeout` atomically (takeTMVar thVar)
|
||||||
pure $ case th_ of
|
pure $ case th_ of
|
||||||
|
|
|
@ -20,19 +20,20 @@ import Network.Socket
|
||||||
import qualified Network.TLS as T
|
import qualified Network.TLS as T
|
||||||
import qualified Simplex.Messaging.Crypto as C
|
import qualified Simplex.Messaging.Crypto as C
|
||||||
import Simplex.Messaging.Transport
|
import Simplex.Messaging.Transport
|
||||||
|
import Simplex.Messaging.Transport.KeepAlive
|
||||||
import System.IO.Error
|
import System.IO.Error
|
||||||
import UnliftIO.Exception (IOException)
|
import UnliftIO.Exception (IOException)
|
||||||
import qualified UnliftIO.Exception as E
|
import qualified UnliftIO.Exception as E
|
||||||
|
|
||||||
-- | Connect to passed TCP host:port and pass handle to the client.
|
-- | Connect to passed TCP host:port and pass handle to the client.
|
||||||
runTransportClient :: Transport c => MonadUnliftIO m => HostName -> ServiceName -> C.KeyHash -> (c -> m a) -> m a
|
runTransportClient :: Transport c => MonadUnliftIO m => HostName -> ServiceName -> C.KeyHash -> Maybe KeepAliveOpts -> (c -> m a) -> m a
|
||||||
runTransportClient host port keyHash client = do
|
runTransportClient host port keyHash keepAliveOpts client = do
|
||||||
let clientParams = mkTLSClientParams host port keyHash
|
let clientParams = mkTLSClientParams host port keyHash
|
||||||
c <- liftIO $ startTCPClient host port clientParams
|
c <- liftIO $ startTCPClient host port clientParams keepAliveOpts
|
||||||
client c `E.finally` liftIO (closeConnection c)
|
client c `E.finally` liftIO (closeConnection c)
|
||||||
|
|
||||||
startTCPClient :: forall c. Transport c => HostName -> ServiceName -> T.ClientParams -> IO c
|
startTCPClient :: forall c. Transport c => HostName -> ServiceName -> T.ClientParams -> Maybe KeepAliveOpts -> IO c
|
||||||
startTCPClient host port clientParams = withSocketsDo $ resolve >>= tryOpen err
|
startTCPClient host port clientParams keepAliveOpts = withSocketsDo $ resolve >>= tryOpen err
|
||||||
where
|
where
|
||||||
err :: IOException
|
err :: IOException
|
||||||
err = mkIOError NoSuchThing "no address" Nothing Nothing
|
err = mkIOError NoSuchThing "no address" Nothing Nothing
|
||||||
|
@ -51,6 +52,7 @@ startTCPClient host port clientParams = withSocketsDo $ resolve >>= tryOpen err
|
||||||
open addr = do
|
open addr = do
|
||||||
sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
|
sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
|
||||||
connect sock $ addrAddress addr
|
connect sock $ addrAddress addr
|
||||||
|
mapM_ (setSocketKeepAlive sock) keepAliveOpts
|
||||||
ctx <- connectTLS clientParams sock
|
ctx <- connectTLS clientParams sock
|
||||||
getClientConnection ctx
|
getClientConnection ctx
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,41 @@
|
||||||
|
{-# LANGUAGE CApiFFI #-}
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
|
|
||||||
|
module Simplex.Messaging.Transport.KeepAlive where
|
||||||
|
|
||||||
|
import Foreign.C (CInt (..))
|
||||||
|
import Network.Socket
|
||||||
|
|
||||||
|
foreign import capi "netinet/tcp.h value TCP_KEEPCNT" tcpKeepCnt :: CInt
|
||||||
|
|
||||||
|
foreign import capi "netinet/tcp.h value TCP_KEEPINTVL" tcpKeepIntvl :: CInt
|
||||||
|
|
||||||
|
#if defined(darwin_HOST_OS)
|
||||||
|
foreign import capi "netinet/tcp.h value TCP_KEEPALIVE" tcpKeepIdle :: CInt
|
||||||
|
foreign import capi "netinet/in.h value IPPROTO_TCP" solTcp :: CInt
|
||||||
|
#else
|
||||||
|
foreign import capi "netinet/tcp.h value TCP_KEEPIDLE" tcpKeepIdle :: CInt
|
||||||
|
foreign import capi "netinet/tcp.h value SOL_TCP" solTcp :: CInt
|
||||||
|
#endif
|
||||||
|
|
||||||
|
data KeepAliveOpts = KeepAliveOpts
|
||||||
|
{ keepCnt :: Int,
|
||||||
|
keepIdle :: Int,
|
||||||
|
keepIntvl :: Int
|
||||||
|
}
|
||||||
|
|
||||||
|
defaultKeepAliveOpts :: KeepAliveOpts
|
||||||
|
defaultKeepAliveOpts =
|
||||||
|
KeepAliveOpts
|
||||||
|
{ keepCnt = 4,
|
||||||
|
keepIdle = 30,
|
||||||
|
keepIntvl = 15
|
||||||
|
}
|
||||||
|
|
||||||
|
setSocketKeepAlive :: Socket -> KeepAliveOpts -> IO ()
|
||||||
|
setSocketKeepAlive sock KeepAliveOpts {keepCnt, keepIdle, keepIntvl} = do
|
||||||
|
setSocketOption sock KeepAlive 1
|
||||||
|
setSocketOption sock (SockOpt solTcp tcpKeepCnt) keepCnt
|
||||||
|
setSocketOption sock (SockOpt solTcp tcpKeepIdle) keepIdle
|
||||||
|
setSocketOption sock (SockOpt solTcp tcpKeepIntvl) keepIntvl
|
|
@ -36,6 +36,7 @@ packages:
|
||||||
#
|
#
|
||||||
extra-deps:
|
extra-deps:
|
||||||
- cryptostore-0.2.1.0@sha256:9896e2984f36a1c8790f057fd5ce3da4cbcaf8aa73eb2d9277916886978c5b19,3881
|
- cryptostore-0.2.1.0@sha256:9896e2984f36a1c8790f057fd5ce3da4cbcaf8aa73eb2d9277916886978c5b19,3881
|
||||||
|
- network-3.1.2.7@sha256:e3d78b13db9512aeb106e44a334ab42b7aa48d26c097299084084cb8be5c5568,4888
|
||||||
- simple-logger-0.1.0@sha256:be8ede4bd251a9cac776533bae7fb643369ebd826eb948a9a18df1a8dd252ff8,1079
|
- simple-logger-0.1.0@sha256:be8ede4bd251a9cac776533bae7fb643369ebd826eb948a9a18df1a8dd252ff8,1079
|
||||||
- tls-1.5.7@sha256:1cc30253a9696b65a9cafc0317fbf09f7dcea15e3a145ed6c9c0e28c632fa23a,6991
|
- tls-1.5.7@sha256:1cc30253a9696b65a9cafc0317fbf09f7dcea15e3a145ed6c9c0e28c632fa23a,6991
|
||||||
# below dependancies are to update Aeson to 2.0.3
|
# below dependancies are to update Aeson to 2.0.3
|
||||||
|
|
|
@ -27,6 +27,7 @@ import Simplex.Messaging.Agent.Server (runSMPAgentBlocking)
|
||||||
import Simplex.Messaging.Client (SMPClientConfig (..), smpDefaultConfig)
|
import Simplex.Messaging.Client (SMPClientConfig (..), smpDefaultConfig)
|
||||||
import Simplex.Messaging.Transport
|
import Simplex.Messaging.Transport
|
||||||
import Simplex.Messaging.Transport.Client
|
import Simplex.Messaging.Transport.Client
|
||||||
|
import Simplex.Messaging.Transport.KeepAlive
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
import UnliftIO.Concurrent
|
import UnliftIO.Concurrent
|
||||||
import UnliftIO.Directory
|
import UnliftIO.Directory
|
||||||
|
@ -190,7 +191,7 @@ withSmpAgent t = withSmpAgentOn t (agentTestPort, testPort, testDB)
|
||||||
|
|
||||||
testSMPAgentClientOn :: (Transport c, MonadUnliftIO m) => ServiceName -> (c -> m a) -> m a
|
testSMPAgentClientOn :: (Transport c, MonadUnliftIO m) => ServiceName -> (c -> m a) -> m a
|
||||||
testSMPAgentClientOn port' client = do
|
testSMPAgentClientOn port' client = do
|
||||||
runTransportClient agentTestHost port' testKeyHash $ \h -> do
|
runTransportClient agentTestHost port' testKeyHash (Just defaultKeepAliveOpts) $ \h -> do
|
||||||
line <- liftIO $ getLn h
|
line <- liftIO $ getLn h
|
||||||
if line == "Welcome to SMP agent v" <> B.pack simplexMQVersion
|
if line == "Welcome to SMP agent v" <> B.pack simplexMQVersion
|
||||||
then client h
|
then client h
|
||||||
|
|
|
@ -22,6 +22,7 @@ import Simplex.Messaging.Server.Env.STM
|
||||||
import Simplex.Messaging.Server.StoreLog (openReadStoreLog)
|
import Simplex.Messaging.Server.StoreLog (openReadStoreLog)
|
||||||
import Simplex.Messaging.Transport
|
import Simplex.Messaging.Transport
|
||||||
import Simplex.Messaging.Transport.Client
|
import Simplex.Messaging.Transport.Client
|
||||||
|
import Simplex.Messaging.Transport.KeepAlive
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
import UnliftIO.Concurrent
|
import UnliftIO.Concurrent
|
||||||
import qualified UnliftIO.Exception as E
|
import qualified UnliftIO.Exception as E
|
||||||
|
@ -45,7 +46,7 @@ testStoreLogFile = "tests/tmp/smp-server-store.log"
|
||||||
|
|
||||||
testSMPClient :: (Transport c, MonadUnliftIO m) => (THandle c -> m a) -> m a
|
testSMPClient :: (Transport c, MonadUnliftIO m) => (THandle c -> m a) -> m a
|
||||||
testSMPClient client =
|
testSMPClient client =
|
||||||
runTransportClient testHost testPort testKeyHash $ \h ->
|
runTransportClient testHost testPort testKeyHash (Just defaultKeepAliveOpts) $ \h ->
|
||||||
liftIO (runExceptT $ clientHandshake h testKeyHash) >>= \case
|
liftIO (runExceptT $ clientHandshake h testKeyHash) >>= \case
|
||||||
Right th -> client th
|
Right th -> client th
|
||||||
Left e -> error $ show e
|
Left e -> error $ show e
|
||||||
|
|
Reference in New Issue