git.iko.soy/distributed-process
on master help sign in
Fix the test (in-memory transport was fine)
commit7a0b324c2b1ed30f52b7e320352e9c5d43ded4f4 authorEdsko de Vries <edsko@edsko.net> dateThu 26 Apr 2012, 16:15 (15 years ago) parent7b1d69b
2 files changed+16−15
compare with master
unifiedsplit
network-transport-2/src/Network/Transport/Chan.hs+6−6 network-transport-2/tests/TestTransport.hs+10−9
network-transport-2/src/Network/Transport/Chan.hs+6−6
@@ -8,7 +8,7 @@ import Control.Category ((>>>))
88import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, modifyMVar_, readMVar)
99import Control.Monad (forM_)
1010import 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)
1212import qualified Data.ByteString.Char8 as BSC (pack)
1313import Data.Lens.Lazy (Lens, lens, (^.), (^%=), (^=), (^+=), mapLens)
1414
@@ -27,17 +27,17 @@ nextConnectionId = lens _nextConnectionId (\cid st -> st { _nextConnectionId =
2727multigroups :: Lens TransportState (Map MulticastAddress (MVar [Chan Event]))
2828multigroups = lens _multigroups (\gs st -> st { _multigroups = gs })
2929
30−at :: Ord k => k -> Lens (Map k v) v
31−at k = lens (Map.! k) (Map.insert k)
30+at :: Ord k => k -> String -> Lens (Map k v) v
31+at k err = lens (Map.findWithDefault (error err) k) (Map.insert k)
3232
3333channelAt :: EndPointAddress -> Lens TransportState (Chan Event)
34−channelAt addr = channels >>> at addr
34+channelAt addr = channels >>> at addr "Invalid channel"
3535
3636nextConnectionIdAt :: EndPointAddress -> Lens TransportState ConnectionId
37−nextConnectionIdAt addr = nextConnectionId >>> at addr
37+nextConnectionIdAt addr = nextConnectionId >>> at addr "Invalid connection ID"
3838
3939multigroupAt :: MulticastAddress -> Lens TransportState (MVar [Chan Event])
40−multigroupAt addr = multigroups >>> at addr
40+multigroupAt addr = multigroups >>> at addr "Invalid multigroup"
4141
4242-- | Create a new Transport.
4343--
network-transport-2/tests/TestTransport.hs+10−9
@@ -8,7 +8,7 @@ import Network.Transport
88import Data.ByteString (ByteString)
99import Data.ByteString.Char8 ()
1010import Data.Map (Map)
11−import qualified Data.Map as Map (empty, insert, (!), delete)
11+import qualified Data.Map as Map (empty, insert, delete, findWithDefault)
1212import Control.Monad.Reader (ReaderT, runReaderT, ask)
1313import Control.Monad.IO.Class (liftIO)
1414import System.IO (hFlush, stdout)
@@ -38,10 +38,10 @@ echoServer endpoint = do
3838 Right conn <- connect endpoint addr rel
3939 go (Map.insert cid conn cs)
4040 Received cid payload -> do
41− send (cs Map.! cid) payload
41+ send (Map.findWithDefault (error $ "Received: Invalid cid " ++ show cid) cid cs) payload
4242 go cs
4343 ConnectionClosed cid -> do
44− close (cs Map.! cid)
44+ close (Map.findWithDefault (error $ "ConnectionClosed: Invalid cid " ++ show cid) cid cs)
4545 go (Map.delete cid cs)
4646 ReceivedMulticast _ _ ->
4747 -- Ignore
@@ -164,7 +164,9 @@ testCloseOneConnection transport numPings = do
164164 ConnectionOpened serv2 _ _ <- receive endpoint
165165
166166 -- One thread to send "pingA" on the first connection
167− forkIO $ replicateM_ numPings $ send conn1 ["pingA"] >> close conn1
167+ forkIO $ do
168+ replicateM_ numPings $ send conn1 ["pingA"]
169+ close conn1
168170
169171 -- One thread to send "pingB" on the second connection
170172 forkIO $ replicateM_ (numPings * 2) $ send conn2 ["pingB"]
@@ -191,18 +193,17 @@ runTestIO description test = do
191193 test
192194 putStrLn "ok"
193195
194−runTest :: String -> (Transport -> Int -> IO ()) -> ReaderT Transport IO ()
196+runTest :: String -> (Transport -> Int -> IO ()) -> ReaderT (Transport, Int) IO ()
195197runTest description test = do
196− transport <- ask
197− done <- liftIO $ timeout 1000000 $ runTestIO description (test transport 1000)
198+ (transport, numPings) <- ask
199+ done <- liftIO $ timeout 1000000 $ runTestIO description (test transport numPings)
198200 case done of
199201 Just () -> return ()
200202 Nothing -> error "timeout"
201203
202−
203204-- Transport tests
204205testTransport :: Transport -> IO ()
205−testTransport = runReaderT $ do
206+testTransport transport = flip runReaderT (transport, 1000) $ do
206207 runTest "PingPong" testPingPong
207208 runTest "EndPoints" testEndPoints
208209 runTest "Connections" testConnections