distributed-process-tests 0.4.6 → 0.4.7

raw patch · 5 files changed

+37/−32 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• distributed-process-tests.cabal +1/−2
• src/Control/Distributed/Process/Tests/CH.hs +27/−21
• src/Control/Distributed/Process/Tests/Closure.hs +5/−3
• src/Control/Distributed/Process/Tests/Receive.hs +1/−4
• tests/runTCP.hs +3/−2

@@ -1,5 +1,5 @@ name:          distributed-process-tests-version:       0.4.6+version:       0.4.7 synopsis:      Tests and test support tools for distributed-process. homepage:      http://github.com/haskell-distributed/distributed-process/tree/master/distributed-process-tests description:   Tests and test suite for Cloud Haskell libraries.@@ -48,7 +48,6 @@                      DeriveDataTypeable,                      DeriveGeneric,                      GeneralizedNewtypeDeriving,-                     OverlappingInstances,                      RankNTypes,                      RecordWildCards,                      ScopedTypeVariables

@@ -560,19 +560,10 @@ testTerminate :: TestTransport -> Assertion testTerminate TestTransport{..} = do   localNode <- newLocalNode testTransport initRemoteTable-  done <- newEmptyMVar--  pid <- forkProcess localNode $ do-    liftIO $ threadDelay 100000-    terminate-   runProcess localNode $ do-    ref <- monitor pid-    ProcessMonitorNotification ref' pid' (DiedException ex) <- expect-    True <- return $ ref == ref' && pid == pid' && ex == show ProcessTerminationException-    liftIO $ putMVar done ()--  takeMVar done+    e <- try terminate :: Process (Either ProcessTerminationException ())+    True <- return $ either show show e == show ProcessTerminationException+    return ()  testMonitorNode :: TestTransport -> Assertion testMonitorNode TestTransport{..} = do@@ -1090,6 +1081,7 @@ testReceiveChanTimeout :: TestTransport -> Assertion testReceiveChanTimeout TestTransport{..} = do   done <- newEmptyMVar+  mvSender <- newEmptyMVar   sendPort <- newEmptyMVar    forkTry $ do@@ -1099,18 +1091,31 @@       (sp, rp) <- newChan :: Process (SendPort Bool, ReceivePort Bool)       liftIO $ putMVar sendPort sp -      -- Wait for a message with a delay. No message arrives, we should get Nothing after 1 second-      Nothing <- receiveChanTimeout 1000000 rp+      -- Wait for a message with a delay. No message arrives, we should get+      -- Nothing after the delay.+      Nothing <- receiveChanTimeout 100000 rp -      -- Wait for a message with a delay again. Now a message arrives after 0.5 seconds-      Just True <- receiveChanTimeout 1000000 rp+      -- Let the sender know that it can send a message.+      liftIO $ putMVar mvSender () -      -- Wait for a message with zero timeout: non-blocking check. No message is available, we get Nothing+      -- Wait for a message with a delay again. Now a message arrives after+      -- 0.1 seconds+      Just True <- receiveChanTimeout 20000000 rp++      -- Wait for a message with zero timeout: non-blocking check. No message is+      -- available, we get Nothing       Nothing <- receiveChanTimeout 0 rp +      -- Let the sender know that it can send a message.+      liftIO $ putMVar mvSender ()+       -- Again, but now there is a message available-      liftIO $ threadDelay 1000000-      Just False <- receiveChanTimeout 0 rp+      fix $ \loop -> do+        liftIO $ threadDelay 100000+        mb <- receiveChanTimeout 0 rp+        case mb of+          Just b -> do False <- return b; return ()+          _      -> loop        liftIO $ putMVar done () @@ -1119,10 +1124,11 @@     runProcess localNode $ do       sp <- liftIO $ readMVar sendPort -      liftIO $ threadDelay 1500000+      liftIO $ takeMVar mvSender+      liftIO $ threadDelay 100000       sendChan sp True -      liftIO $ threadDelay 500000+      liftIO $ takeMVar mvSender       sendChan sp False    takeMVar done

@@ -305,14 +305,16 @@     wrapEP e =       e { NT.connect = \x y z -> do             healthy <- newIORef True-            fmap (fmap $ wrapConnection healthy) $ NT.connect e x y z+            fmap (fmap $ wrapConnection healthy e x) $ NT.connect e x y z         } -    wrapConnection :: IORef Bool -> NT.Connection -> NT.Connection-    wrapConnection healthy (NT.Connection s closeC) =+    wrapConnection :: IORef Bool -> NT.EndPoint -> NT.EndPointAddress+                   -> NT.Connection -> NT.Connection+    wrapConnection healthy e remoteAddr (NT.Connection s closeC) =       flip NT.Connection closeC $ \msg -> do         when (msg == messageToPayload (createMessage ())) $ do           writeIORef healthy False+          testBreakConnection (NT.address e) remoteAddr         isHealthy <- readIORef healthy         if isHealthy then s msg           else return $ Left $ NT.TransportError NT.SendFailed ""

@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wall #-}  -- | XXX test doesn't work, because failure exceptions don't get propagated. The@@ -14,9 +14,6 @@ import Control.Distributed.Process.Node  import Control.Monad-import Text.Printf-import Data.Binary-import Data.Typeable  import Test.HUnit (Assertion, (@?=)) import Test.Framework (Test, defaultMain)

@@ -15,6 +15,7 @@ import Test.Framework (defaultMainWithArgs)  import Control.Concurrent (threadDelay)+import Control.Exception  (IOException, try) import System.Environment (getArgs) import System.IO @@ -28,8 +29,8 @@     ts <- tests TestTransport       { testTransport = transport       , testBreakConnection = \addr1 addr2 -> do-          sock <- socketBetween internals addr1 addr2-          sClose sock+          esock <- try $ socketBetween internals addr1 addr2+          either (\e -> const (return ()) (e :: IOException)) sClose esock           threadDelay 10000       }     args <- getArgs