git.iko.soy/distributed-process
on master help sign in
Fix the test (in-memory transport was fine)
7a0b324Edsko de Vries
network-transport-2/src/Network/Transport/Chan.hs+6−6
compare with master
unifiedsplit
@@ -8,7 +8,7 @@ import Control.Category ((>>>))
8import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, modifyMVar_, readMVar)
8import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, modifyMVar_, readMVar)
9import Control.Monad (forM_)
9import Control.Monad (forM_)
10import Data.Map (Map)
10import Data.Map (Map)
11−import qualified Data.Map as Map (empty, insert, (!), size, delete)
11+import qualified Data.Map as Map (empty, insert, size, delete, findWithDefault)
12import qualified Data.ByteString.Char8 as BSC (pack)
12import qualified Data.ByteString.Char8 as BSC (pack)
13import Data.Lens.Lazy (Lens, lens, (^.), (^%=), (^=), (^+=), mapLens)
13import Data.Lens.Lazy (Lens, lens, (^.), (^%=), (^=), (^+=), mapLens)
14
14
@@ -27,17 +27,17 @@ nextConnectionId = lens _nextConnectionId (\cid st -> st { _nextConnectionId =
27multigroups :: Lens TransportState (Map MulticastAddress (MVar [Chan Event]))
27multigroups :: Lens TransportState (Map MulticastAddress (MVar [Chan Event]))
28multigroups = lens _multigroups (\gs st -> st { _multigroups = gs })
28multigroups = lens _multigroups (\gs st -> st { _multigroups = gs })
29
29
30−at :: Ord k => k -> Lens (Map k v) v
30+at :: Ord k => k -> String -> Lens (Map k v) v
31−at k = lens (Map.! k) (Map.insert k)
31+at k err = lens (Map.findWithDefault (error err) k) (Map.insert k)
32
32
33channelAt :: EndPointAddress -> Lens TransportState (Chan Event)
33channelAt :: EndPointAddress -> Lens TransportState (Chan Event)
34−channelAt addr = channels >>> at addr
34+channelAt addr = channels >>> at addr "Invalid channel"
35
35
36nextConnectionIdAt :: EndPointAddress -> Lens TransportState ConnectionId
36nextConnectionIdAt :: EndPointAddress -> Lens TransportState ConnectionId
37−nextConnectionIdAt addr = nextConnectionId >>> at addr
37+nextConnectionIdAt addr = nextConnectionId >>> at addr "Invalid connection ID"
38
38
39multigroupAt :: MulticastAddress -> Lens TransportState (MVar [Chan Event])
39multigroupAt :: MulticastAddress -> Lens TransportState (MVar [Chan Event])
40−multigroupAt addr = multigroups >>> at addr
40+multigroupAt addr = multigroups >>> at addr "Invalid multigroup"
41
41
42-- | Create a new Transport.
42-- | Create a new Transport.
43--
43--
network-transport-2/tests/TestTransport.hs+10−9
@@ -8,7 +8,7 @@ import Network.Transport
8import Data.ByteString (ByteString)
8import Data.ByteString (ByteString)
9import Data.ByteString.Char8 ()
9import Data.ByteString.Char8 ()
10import Data.Map (Map)
10import Data.Map (Map)
11−import qualified Data.Map as Map (empty, insert, (!), delete)
11+import qualified Data.Map as Map (empty, insert, delete, findWithDefault)
12import Control.Monad.Reader (ReaderT, runReaderT, ask)
12import Control.Monad.Reader (ReaderT, runReaderT, ask)
13import Control.Monad.IO.Class (liftIO)
13import Control.Monad.IO.Class (liftIO)
14import System.IO (hFlush, stdout)
14import System.IO (hFlush, stdout)
@@ -38,10 +38,10 @@ echoServer endpoint = do
38 Right conn <- connect endpoint addr rel
38 Right conn <- connect endpoint addr rel
39 go (Map.insert cid conn cs)
39 go (Map.insert cid conn cs)
40 Received cid payload -> do
40 Received cid payload -> do
41− send (cs Map.! cid) payload
41+ send (Map.findWithDefault (error $ "Received: Invalid cid " ++ show cid) cid cs) payload
42 go cs
42 go cs
43 ConnectionClosed cid -> do
43 ConnectionClosed cid -> do
44− close (cs Map.! cid)
44+ close (Map.findWithDefault (error $ "ConnectionClosed: Invalid cid " ++ show cid) cid cs)
45 go (Map.delete cid cs)
45 go (Map.delete cid cs)
46 ReceivedMulticast _ _ ->
46 ReceivedMulticast _ _ ->
47 -- Ignore
47 -- Ignore
@@ -164,7 +164,9 @@ testCloseOneConnection transport numPings = do
164 ConnectionOpened serv2 _ _ <- receive endpoint
164 ConnectionOpened serv2 _ _ <- receive endpoint
165
165
166 -- One thread to send "pingA" on the first connection
166 -- One thread to send "pingA" on the first connection
167+ forkIO $ do
167− forkIO $ replicateM_ numPings $ send conn1 ["pingA"] >> close conn1
168+ replicateM_ numPings $ send conn1 ["pingA"]
169+ close conn1
168
170
169 -- One thread to send "pingB" on the second connection
171 -- One thread to send "pingB" on the second connection
170 forkIO $ replicateM_ (numPings * 2) $ send conn2 ["pingB"]
172 forkIO $ replicateM_ (numPings * 2) $ send conn2 ["pingB"]
@@ -191,18 +193,17 @@ runTestIO description test = do
191 test
193 test
192 putStrLn "ok"
194 putStrLn "ok"
193
195
194−runTest :: String -> (Transport -> Int -> IO ()) -> ReaderT Transport IO ()
196+runTest :: String -> (Transport -> Int -> IO ()) -> ReaderT (Transport, Int) IO ()
195runTest description test = do
197runTest description test = do
196− transport <- ask
198+ (transport, numPings) <- ask
197− done <- liftIO $ timeout 1000000 $ runTestIO description (test transport 1000)
199+ done <- liftIO $ timeout 1000000 $ runTestIO description (test transport numPings)
198 case done of
200 case done of
199 Just () -> return ()
201 Just () -> return ()
200 Nothing -> error "timeout"
202 Nothing -> error "timeout"
201
203
202−
203-- Transport tests
204-- Transport tests
204testTransport :: Transport -> IO ()
205testTransport :: Transport -> IO ()
205−testTransport = runReaderT $ do
206+testTransport transport = flip runReaderT (transport, 1000) $ do
206 runTest "PingPong" testPingPong
207 runTest "PingPong" testPingPong
207 runTest "EndPoints" testEndPoints
208 runTest "EndPoints" testEndPoints
208 runTest "Connections" testConnections
209 runTest "Connections" testConnections