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
99fcf6dAgentM
project-m36.cabal+1
compare with master
unifiedsplit
@@ -62,6 +62,7 @@ Library
62 ,distributed-process-client-server
62 ,distributed-process-client-server
63 ,distributed-process
63 ,distributed-process
64 ,distributed-process-extras
64 ,distributed-process-extras
65+ ,distributed-process-async
65 ,network-transport-tcp
66 ,network-transport-tcp
66 ,network-transport
67 ,network-transport
67 ,stm-containers
68 ,stm-containers
src/lib/ProjectM36/Server/EntryPoints.hs+9−6
@@ -6,20 +6,23 @@ import ProjectM36.Error
6import Control.Distributed.Process (Process, ProcessId)
6import Control.Distributed.Process (Process, ProcessId)
7import Control.Distributed.Process.ManagedProcess (ProcessReply)
7import Control.Distributed.Process.ManagedProcess (ProcessReply)
8import Control.Distributed.Process.ManagedProcess.Server (reply)
8import 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)
9import Control.Monad.IO.Class (liftIO)
12import Control.Monad.IO.Class (liftIO)
10import Data.Map
13import Data.Map
11−import System.Timeout
12import Control.Concurrent (threadDelay)
14import Control.Concurrent (threadDelay)
13
15
14−timeoutOrDie :: Timeout -> IO a -> Process (Either ServerError a)
16+timeoutOrDie :: Serializable a => Timeout -> IO a -> Process (Either ServerError a)
15timeoutOrDie micros act = do
17timeoutOrDie micros act = do
16 if micros == 0 then
18 if micros == 0 then
17 liftIO act >>= \x -> pure (Right x)
19 liftIO act >>= \x -> pure (Right x)
18 else do
20 else do
19− mRes <- liftIO (timeout micros act)
21+ asyncUnit <- async (task (liftIO act))
22+ asyncRes <- waitCancelTimeout (microSeconds micros) asyncUnit
20− case mRes of
23+ case asyncRes of
21− Just res -> pure (Right res)
24+ AsyncDone x -> pure (Right x)
22− Nothing -> pure (Left RequestTimeoutError)
25+ AsyncCancelled -> pure (Left RequestTimeoutError)
23
26
24type Timeout = Int
27type Timeout = Int
25
28
test/Server/Main.hs+30−2
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-
2{-
2test client/server interaction
3test client/server interaction
3-}
4-}
@@ -13,6 +14,7 @@ import ProjectM36.IsomorphicSchema
13import ProjectM36.Base
14import ProjectM36.Base
14
15
15import System.Exit
16import System.Exit
17+
16import Control.Concurrent
18import Control.Concurrent
17import Network.Transport (EndPointAddress)
19import Network.Transport (EndPointAddress)
18import Network.Transport.TCP (encodeEndPointAddress, decodeEndPointAddress)
20import Network.Transport.TCP (encodeEndPointAddress, decodeEndPointAddress)
@@ -20,6 +22,9 @@ import Data.Either (isRight)
20import Data.Maybe (isJust)
22import Data.Maybe (isJust)
21import Control.Exception
23import Control.Exception
22--import Control.Monad.IO.Class
24--import Control.Monad.IO.Class
25+#if defined(linux_HOST_OS)
26+import System.Directory
27+#endif
23
28
24testList :: SessionId -> Connection -> MVar () -> Test
29testList :: SessionId -> Connection -> MVar () -> Test
25testList sessionId conn notificationTestMVar = TestList $ serverTests ++ sessionTests
30testList sessionId conn notificationTestMVar = TestList $ serverTests ++ sessionTests
@@ -38,7 +43,7 @@ testList sessionId conn notificationTestMVar = TestList $ serverTests ++ session
38 testRelationVariableSummary,
43 testRelationVariableSummary,
39 testNotification notificationTestMVar
44 testNotification notificationTestMVar
40 ]
45 ]
41− serverTests = [testRequestTimeout]
46+ serverTests = [testRequestTimeout, testFileDescriptorCount]
42
47
43main :: IO ()
48main :: IO ()
44main = do
49main = do
@@ -205,4 +210,27 @@ testRequestTimeout = TestCase $ do
205 Right (session, testConn) -> do
210 Right (session, testConn) -> do
206 res <- catchJust (\exc -> if exc == RequestTimeoutException then Just exc else Nothing) (callTestTimeout_ session testConn) (const (pure False))
211 res <- catchJust (\exc -> if exc == RequestTimeoutException then Just exc else Nothing) (callTestTimeout_ session testConn) (const (pure False))
207 assertBool "exception was not thrown" (not res)
212 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