9f87d95 · curryer · git.iko.soy

git.iko.soy/curryer

add client-side-only timeout feature

commit9f87d95f227940e016d60abd4e906ade041aeeaa authorAgentM <agentm@themactionfaction.com> dateSun 11 Oct 2020, 00:07 (6 years ago) parent791da98

3 files changed+52−10

compare with master

unifiedsplit

curryer.cabal+1 src/Network/RPC/Curryer/Client.hs+23−9 test/Curryer/Test/Basic.hs+28−1

curryer.cabal+1

@@ -31,6 +31,7 @@ Library

3131 , containers

3232 , stm-containers

3333 , hashable

34+ , time

3435 Hs-Source-Dirs: ./src

3536 Default-Language: Haskell2010

3637 ghc-options: -Wall -fwarn-unused-binds -fwarn-unused-imports

src/Network/RPC/Curryer/Client.hs+23−9

@@ -8,8 +8,10 @@ import qualified Data.UUID.V4 as UUIDBase

88import qualified StmContainers.Map as STMMap

99import Control.Concurrent.MVar

1010import GHC.Conc

11+import Data.Time.Clock

12+import System.Timeout

1113

12−type SyncMap a = STMMap.Map UUID (MVar a)

14+type SyncMap a = STMMap.Map UUID (MVar a, UTCTime)

1315-- the request map holds

1416data Connection a = Connection Socket (Async ()) (SyncMap a)

1517

@@ -42,29 +44,41 @@ clientAsync sock syncmap asyncHandler = do

4244 case responseMsg of

4345 Response requestId val -> do

4446 varval <- atomically $ do

45− v <- STMMap.lookup requestId syncmap

47+ val' <- STMMap.lookup requestId syncmap

4648 STMMap.delete requestId syncmap

47− pure v

49+ pure val'

4850 case varval of

4951 Nothing -> error "dumped unrequested response"

50− Just mVar -> putMVar mVar val

52+ Just (mVar,_) -> putMVar mVar val

5153 AsyncRequest _ asyncMsg ->

5254 asyncHandler asyncMsg

5355 ResponseExpectedRequest _ _ -> error "dumped response expected request"

5456 ExceptionResponse _ -> error "TODO Exception"

5557 drainSocketMessages sock responseHandler

5658

57−-- | Send a request to the remote server and returns a response.

5859call :: (Serialise request, Serialise response) => Connection response -> request -> IO (Either ConnectionError response)

59−call (Connection sock _ mVarMap) msg = do

60+call = callTimeout Nothing

61+

62+-- | Send a request to the remote server and returns a response.

63+callTimeout :: (Serialise request, Serialise response) => Maybe Int -> Connection response -> request -> IO (Either ConnectionError response)

64+callTimeout mTimeout (Connection sock _ mVarMap) msg = do

6065 requestID <- UUID <$> UUIDBase.nextRandom

6166 -- setup mvar to wait for response

6267 responseMVar <- newEmptyMVar

63− atomically $ STMMap.insert responseMVar requestID mVarMap

68+ now <- getCurrentTime

69+ atomically $ STMMap.insert (responseMVar, now) requestID mVarMap

6470 sendMessage (ResponseExpectedRequest requestID msg) sock

65− response <- takeMVar responseMVar

71+ let timeoutMicroseconds =

72+ case mTimeout of

73+ Just timeout' -> timeout'

74+ Nothing -> -1

75+ mResponse <- timeout timeoutMicroseconds (takeMVar responseMVar)

6676 atomically $ STMMap.delete requestID mVarMap

67− pure (Right response)

77+ case mResponse of

78+ --timeout

79+ Nothing -> do

80+ pure (Left TimeoutError)

81+ Just response -> pure (Right response)

6882

6983asyncCall :: (Serialise request, Serialise response) => Connection response -> request -> IO (Either ConnectionError ())

7084asyncCall (Connection sock _ _) msg = do

test/Curryer/Test/Basic.hs+28−1

@@ -8,6 +8,7 @@ import Control.Concurrent.MVar

88import Network.Socket (SockAddr(..))

99import Control.Concurrent.Async

1010import Control.Monad

11+import Control.Concurrent

1112

1213import Network.RPC.Curryer.Server

1314import Network.RPC.Curryer.Client

@@ -15,13 +16,15 @@ import Network.RPC.Curryer.Client

1516testTree :: TestTree

1617testTree = testGroup "basic" [testCase "simple" testSimpleCall,

1718 testCase "client async" testAsyncServerCall,

18− testCase "server async" testAsyncClientCall

19+ testCase "server async" testAsyncClientCall,

20+ testCase "client sync timeout" testSyncClientCallTimeout

1921 ]

2022

2123--client-to-server request

2224data TestRequest = AddTwoNumbersReq Int Int

2325 | TestAsyncReq String

2426 | TestCallMeBackReq String

27+ | DelayMicrosecondsReq Int

2528 deriving (Generic, Show)

2629 deriving Serialise via WineryVariant TestRequest

2730

@@ -29,6 +32,7 @@ data TestRequest = AddTwoNumbersReq Int Int

2932data TestResponse = AddTwoNumbersResp Int

3033 | AsyncHello String

3134 | TestCallMeBackResp String

35+ | DelayMicrosecondsResp

3236 deriving (Generic, Show, Eq)

3337 deriving Serialise via WineryVariant TestResponse

3438

@@ -45,6 +49,9 @@ testServerMessageHandler mAsyncMVar msg = do

4549 Just mvar -> putMVar mvar s

4650 pure NoResponse

4751 TestAsyncReq _ -> pure NoResponse

52+ DelayMicrosecondsReq ms -> do

53+ threadDelay ms

54+ pure (HandlerResponse DelayMicrosecondsResp)

4855

4956-- test a simple client-to-server round-trip function execution

5057testSimpleCall :: Assertion

@@ -106,3 +113,23 @@ testAsyncClientCall = do

106113 assertEqual "async message" "hi server" asyncMessage

107114 close conn

108115 cancel server

116+

117+testSyncClientCallTimeout :: Assertion

118+testSyncClientCallTimeout = do

119+ readyVar <- newEmptyMVar

120+

121+ server <- async (serve (pure Nothing) (testServerMessageHandler Nothing) localHostAddr 0 (Just readyVar))

122+ --wait for server to be ready

123+ (SockAddrInet port _) <- takeMVar readyVar

124+ let clientHandler :: AsyncMessageHandler TestResponse

125+ clientHandler _ = error "async handler called"

126+ mkConn :: IO (Connection TestResponse)

127+ mkConn = connect clientHandler localHostAddr port

128+ conn <- mkConn

129+ let c :: IO (Either ConnectionError TestResponse)

130+ c = callTimeout (Just 1000) conn (DelayMicrosecondsReq 500)

131+ x <- c

132+ assertEqual "client sync timeout" (Left TimeoutError) x

133+ close conn

134+ cancel server

135+