git.iko.soy/project-m36
on master help sign in
switch to using async timeout as suggested by Tim Watson in https://github.com/haskell-distributed/distributed-process-client-server/issues/7
commit99fcf6de91e6cd92cf81a2c3c4955517eeaba207 authorAgentM <agentm@themactionfaction.com> dateFri 3 Feb 2017, 23:06 (10 years ago) parent80d74a6
3 files changed+40−8
compare with master
unifiedsplit
project-m36.cabal+1 src/lib/ProjectM36/Server/EntryPoints.hs+9−6 test/Server/Main.hs+30−2
project-m36.cabal+1
@@ -62,6 +62,7 @@ Library
6262 ,distributed-process-client-server
6363 ,distributed-process
6464 ,distributed-process-extras
65+ ,distributed-process-async
6566 ,network-transport-tcp
6667 ,network-transport
6768 ,stm-containers
src/lib/ProjectM36/Server/EntryPoints.hs+9−6
@@ -6,20 +6,23 @@ import ProjectM36.Error
66import Control.Distributed.Process (Process, ProcessId)
77import Control.Distributed.Process.ManagedProcess (ProcessReply)
88import Control.Distributed.Process.ManagedProcess.Server (reply)
9+import Control.Distributed.Process.Async (async, task, waitCancelTimeout, AsyncResult(..))
10+import Control.Distributed.Process.Extras.Time (microSeconds)
11+import Control.Distributed.Process.Serializable (Serializable)
912import Control.Monad.IO.Class (liftIO)
1013import Data.Map
11−import System.Timeout
1214import Control.Concurrent (threadDelay)
1315
14−timeoutOrDie :: Timeout -> IO a -> Process (Either ServerError a)
16+timeoutOrDie :: Serializable a => Timeout -> IO a -> Process (Either ServerError a)
1517timeoutOrDie micros act = do
1618 if micros == 0 then
1719 liftIO act >>= \x -> pure (Right x)
1820 else do
19− mRes <- liftIO (timeout micros act)
20− case mRes of
21− Just res -> pure (Right res)
22− Nothing -> pure (Left RequestTimeoutError)
21+ asyncUnit <- async (task (liftIO act))
22+ asyncRes <- waitCancelTimeout (microSeconds micros) asyncUnit
23+ case asyncRes of
24+ AsyncDone x -> pure (Right x)
25+ AsyncCancelled -> pure (Left RequestTimeoutError)
2326
2427type Timeout = Int
2528
test/Server/Main.hs+30−2
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-
23test client/server interaction
34-}
@@ -13,6 +14,7 @@ import ProjectM36.IsomorphicSchema
1314import ProjectM36.Base
1415
1516import System.Exit
17+
1618import Control.Concurrent
1719import Network.Transport (EndPointAddress)
1820import Network.Transport.TCP (encodeEndPointAddress, decodeEndPointAddress)
@@ -20,6 +22,9 @@ import Data.Either (isRight)
2022import Data.Maybe (isJust)
2123import Control.Exception
2224--import Control.Monad.IO.Class
25+#if defined(linux_HOST_OS)
26+import System.Directory
27+#endif
2328
2429testList :: SessionId -> Connection -> MVar () -> Test
2530testList sessionId conn notificationTestMVar = TestList $ serverTests ++ sessionTests
@@ -38,7 +43,7 @@ testList sessionId conn notificationTestMVar = TestList $ serverTests ++ session
3843 testRelationVariableSummary,
3944 testNotification notificationTestMVar
4045 ]
41− serverTests = [testRequestTimeout]
46+ serverTests = [testRequestTimeout, testFileDescriptorCount]
4247
4348main :: IO ()
4449main = do
@@ -205,4 +210,27 @@ testRequestTimeout = TestCase $ do
205210 Right (session, testConn) -> do
206211 res <- catchJust (\exc -> if exc == RequestTimeoutException then Just exc else Nothing) (callTestTimeout_ session testConn) (const (pure False))
207212 assertBool "exception was not thrown" (not res)
208− killThread serverTid
213+ killThread serverTid
214+
215+testFileDescriptorCount :: Test
216+#if defined(linux_HOST_OS)
217+--validate that creating a server, connecting a client, and then disconnecting doesn't leak file descriptors
218+testFileDescriptorCount = TestCase $ do
219+ (serverAddress, serverTid) <- launchTestServer 1000
220+ startCount <- fdCount
221+ unusedMVar <- newEmptyMVar
222+ Right (_, testConn) <- testConnection serverAddress unusedMVar
223+ close testConn
224+ endCount <- fdCount
225+ assertEqual "fd leak" startCount endCount
226+ killThread serverTid
227+
228+-- returns the number of open file descriptors -- linux only /proc usage
229+fdCount :: IO Int
230+fdCount = do
231+ fds <- getDirectoryContents "/proc/self/fd"
232+ pure ((length fds) - 2)
233+#else
234+ --pass on non-linux platforms
235+ testFileDescriptorCount = TestCase (pure ())
236+#endif