git.iko.soy/distributed-process
on master help sign in
Start introducing simulated network errors

Script verification does not yet handle these errors

commit95c824ed6295478dd1ea63541cac33a5027fa8d4 authorEdsko de Vries <edsko@edsko.net> dateWed 17 Oct 2012, 13:13 (14 years ago) parentc9cc0d1
2 files changed+129−32
compare with master
unifiedsplit
network-transport-tcp/src/Network/Transport/TCP/Mock/Socket.hs+60−14 network-transport-tcp/tests/TestQC.hs+69−18
network-transport-tcp/src/Network/Transport/TCP/Mock/Socket.hs+60−14
@@ -25,6 +25,8 @@ module Network.Transport.TCP.Mock.Socket
2525 , defaultHints
2626 , defaultProtocol
2727 , sOMAXCONN
28+ -- * Debugging API
29+ , scheduleReadAction
2830 -- * Internal API
2931 , writeSocket
3032 , readSocket
@@ -39,7 +41,7 @@ import Control.Category ((>>>))
3941import Control.Concurrent.MVar
4042import Control.Concurrent.Chan
4143import System.IO.Unsafe (unsafePerformIO)
42−import Data.Accessor (Accessor, accessor, (^=), (^.))
44+import Data.Accessor (Accessor, accessor, (^=), (^.), (^:))
4345import qualified Data.Accessor.Container as DAC (mapMaybe)
4446import System.Timeout (timeout)
4547
@@ -105,8 +107,14 @@ data Socket = Socket {
105107
106108data SocketState =
107109 Uninit
108− | BoundSocket { socketBacklog :: Chan (Socket, SockAddr, MVar Socket) }
109− | Connected { socketPeer :: Maybe Socket, socketBuff :: Chan Message }
110+ | BoundSocket {
111+ socketBacklog :: Chan (Socket, SockAddr, MVar Socket)
112+ }
113+ | Connected {
114+ socketBuff :: Chan Message
115+ , _socketPeer :: Maybe Socket
116+ , _scheduledReadActions :: [(Int, IO ())]
117+ }
110118 | Closed
111119
112120data Message =
@@ -127,6 +135,12 @@ instance Show AddrInfo where
127135instance Show Socket where
128136 show sock = "<<socket " ++ socketDescription sock ++ ">>"
129137
138+socketPeer :: Accessor SocketState (Maybe Socket)
139+socketPeer = accessor _socketPeer (\peer st -> st { _socketPeer = peer })
140+
141+scheduledReadActions :: Accessor SocketState [(Int, IO ())]
142+scheduledReadActions = accessor _scheduledReadActions (\acts st -> st { _scheduledReadActions = acts })
143+
130144getAddrInfo :: Maybe AddrInfo -> Maybe HostName -> Maybe ServiceName -> IO [AddrInfo]
131145getAddrInfo _ (Just host) (Just port) = do
132146 validHosts <- get validHostnames
@@ -183,8 +197,9 @@ accept serverSock = do
183197 (theirSocket, theirAddress, reply) <- readChan backlog
184198 ourBuff <- newChan
185199 ourState <- newMVar Connected {
186− socketPeer = Just theirSocket
187− , socketBuff = ourBuff
200+ socketBuff = ourBuff
201+ , _socketPeer = Just theirSocket
202+ , _scheduledReadActions = []
188203 }
189204 let ourSocket = Socket {
190205 socketState = ourState
@@ -225,8 +240,9 @@ connect us serverAddr = do
225240 Uninit -> do
226241 buff <- newChan
227242 return Connected {
228− socketPeer = Just them
229− , socketBuff = buff
243+ socketBuff = buff
244+ , _socketPeer = Just them
245+ , _scheduledReadActions = []
230246 }
231247 _ ->
232248 throwSocketError "connect: already connected"
@@ -240,7 +256,7 @@ shutdown sock ShutdownSend = do
240256 writeSocket sock CloseSocket
241257 timeoutThrow mvarThreshold $ modifyMVar_ (socketState sock) $ \st -> case st of
242258 Connected {} ->
243− return (Connected Nothing (socketBuff st))
259+ return (socketPeer ^= Nothing $ st)
244260 _ ->
245261 return st
246262
@@ -252,7 +268,7 @@ peerBuffer :: Socket -> IO (Either String (Chan Message))
252268peerBuffer sock = do
253269 mPeer <- timeoutThrow mvarThreshold $ withMVar (socketState sock) $ \st -> case st of
254270 Connected {} ->
255− return (socketPeer st)
271+ return (st ^. socketPeer)
256272 _ ->
257273 return Nothing
258274 case mPeer of
@@ -277,13 +293,17 @@ writeSocket sock msg = do
277293
278294readSocket :: Socket -> IO (Maybe Word8)
279295readSocket sock = do
280− mBuff <- timeoutThrow mvarThreshold $ withMVar (socketState sock) $ \st -> case st of
281− Connected {} ->
282− return (Just $ socketBuff st)
296+ mBuff <- timeoutThrow mvarThreshold $ modifyMVar (socketState sock) $ \st -> case st of
297+ Connected {} -> do
298+ let (later, now) = tick $ st ^. scheduledReadActions
299+ return ( scheduledReadActions ^= later $ st
300+ , Just (socketBuff st, now)
301+ )
283302 _ ->
284− return Nothing
303+ return (st, Nothing)
285304 case mBuff of
286− Just buff -> do
305+ Just (buff, actions) -> do
306+ sequence actions
287307 msg <- timeoutThrow readSocketThreshold $ readChan buff
288308 case msg of
289309 Payload w -> return (Just w)
@@ -295,6 +315,32 @@ readSocket sock = do
295315 Nothing ->
296316 return Nothing
297317
318+-- | Given a list of scheduled actions, reduce all delays by 1, and return the
319+-- actions that should be executed now.
320+tick :: [(Int, IO ())] -> ([(Int, IO ())], [IO ()])
321+tick = go [] []
322+ where
323+ go later now [] = (reverse later, reverse now)
324+ go later now ((n, action) : actions)
325+ | n == 0 = go later (action : now) actions
326+ | otherwise = go ((n - 1, action) : later) now actions
327+
328+--------------------------------------------------------------------------------
329+-- Debugging API --
330+--------------------------------------------------------------------------------
331+
332+-- | Schedule an action to be executed after /n/ reads on this socket
333+--
334+-- If /n/ is zero we execute the action immediately.
335+scheduleReadAction :: Socket -> Int -> IO () -> IO ()
336+scheduleReadAction _ 0 action = action
337+scheduleReadAction sock n action =
338+ modifyMVar_ (socketState sock) $ \st -> case st of
339+ Connected {} ->
340+ return (scheduledReadActions ^: ((n, action) :) $ st)
341+ _ ->
342+ throwSocketError "scheduleReadAction: socket not connected"
343+
298344--------------------------------------------------------------------------------
299345-- Util --
300346--------------------------------------------------------------------------------
network-transport-tcp/tests/TestQC.hs+69−18
@@ -17,6 +17,7 @@ import Test.QuickCheck
1717 , forAllShrink
1818 , Property
1919 , Arbitrary(arbitrary)
20+ , elements
2021 )
2122import Test.QuickCheck.Property (morallyDubiousIOProperty, Result(..), result)
2223import Test.HUnit (Assertion, assertFailure)
@@ -32,23 +33,47 @@ import Data.ByteString.Char8 (pack)
3233import qualified Data.ByteString as BSS (concat)
3334
3435import Network.Transport
35−import Network.Transport.TCP (createTransport, defaultTCPParameters)
36+import Network.Transport.TCP
37+ ( createTransportExposeInternals
38+ , defaultTCPParameters
39+ , TransportInternals(socketBetween)
40+ )
41+
42+import Network.Transport.TCP.Mock.Socket (scheduleReadAction, sClose)
3643
3744--------------------------------------------------------------------------------
3845-- Script infrastructure --
3946--------------------------------------------------------------------------------
4047
48+-- | We randomly generate /scripts/ which are essentially a deep embedding of
49+-- the Transport API. These scripts are then executed and the results compared
50+-- against an abstract interpreter.
4151data ScriptCmd =
52+ -- | Create a new endpoint
4253 NewEndPoint
54+ -- | @Connect i j@ creates a connection from endpoint @i@ to endpoint @j@,
55+ -- where @i@ and @j@ are indices and refer to the @i@th and @j@th endpoint
56+ -- created by NewEndPoint
4357 | Connect Int Int
58+ -- | @Close i@ closes the @i@ connection created using 'Connect'. Note that
59+ -- closing a connection does not shift other indices; in other words, in
60+ -- @[Connect 0 0, Close 0, Connect 0 0, Close 0]@ the second 'Close'
61+ -- refers to the first (already closed) connection
4462 | Close Int
63+ -- | @Send i bs@ sends payload @bs@ on the @i@ connection created
4564 | Send Int [ByteString]
65+ -- | @BreakAfterReads n i j@ force-closes the socket between endpoints @i@
66+ -- and @j@ after @n@ reads by @i@
67+ --
68+ -- We should have @i /= j@ because the TCP transport does not use sockets
69+ -- for connections from an endpoint to itself
70+ | BreakAfterReads Int Int Int
4671 deriving Show
4772
4873type Script = [ScriptCmd]
4974
50−execScript :: Transport -> Script -> IO (Map Int [Event])
51−execScript transport script = do
75+execScript :: (Transport, TransportInternals) -> Script -> IO (Map Int [Event])
76+execScript (transport, transportInternals) script = do
5277 chan <- newChan
5378 runScript chan script
5479 collectAll chan
@@ -78,6 +103,10 @@ execScript transport script = do
78103 Right () <- send (conns !! connIx) payload
79104 threadDelay 10000
80105 go endPoints conns cmds
106+ go endPoints conns (BreakAfterReads n i j : cmds) = do
107+ sock <- socketBetween transportInternals (address (endPoints !! i)) (address (endPoints !! j))
108+ scheduleReadAction sock n (sClose sock)
109+ go endPoints conns cmds
81110
82111 forwardTo :: Chan (Maybe (Int, Event)) -> (Int, EndPoint) -> IO ()
83112 forwardTo chan (ix, endPoint) = go
@@ -136,6 +165,8 @@ verify script = go script []
136165 go cmds conns (Map.insert epIx epEvs' evs)
137166 _ ->
138167 Just $ "Missing (Received " ++ show connId ++ " " ++ show payload ++ ") event in " ++ show epEvs
168+ go (BreakAfterReads n i j : cmds) conns evs =
169+ go cmds conns evs
139170
140171--------------------------------------------------------------------------------
141172-- Script generators --
@@ -223,6 +254,25 @@ script_ConnectSendClose numEndPoints = do
223254 isOpen :: Map Int Bool -> Int -> Bool
224255 isOpen conns connIx = connIx `Map.member` conns && conns Map.! connIx
225256
257+withErrors :: Int -> Gen Script -> Gen Script
258+withErrors numErrors gen = gen >>= insertError numErrors
259+ where
260+ insertError :: Int -> Script -> Gen Script
261+ insertError _ [] = return []
262+ insertError n (Connect i j : cmds) | i /= j = do
263+ insert <- arbitrary
264+ if insert && n > 0
265+ then do
266+ -- We sometimes want big delays, but usually we want short delays
267+ numReads <- elements (concat (replicate 10 [0 .. 9]) ++ [10 ..99])
268+ return $ Connect i j : BreakAfterReads numReads i j : cmds
269+ else do
270+ cmds' <- insertError (n - 1) cmds
271+ return $ Connect i j : cmds'
272+ insertError n (cmd : cmds) = do
273+ cmds' <- insertError n cmds
274+ return $ cmd : cmds'
275+
226276--------------------------------------------------------------------------------
227277-- Individual scripts to test specific bugs --
228278--------------------------------------------------------------------------------
@@ -283,41 +333,42 @@ script_Bug1 = [
283333-- Main application driver --
284334--------------------------------------------------------------------------------
285335
286−basicTests :: Transport -> Int -> [Test]
287−basicTests transport numEndPoints = [
288− testGen "NewEndPoint" transport (script_NewEndPoint 2)
289− , testGen "Connect" transport (script_Connect 2)
290− , testGen "ConnectClose" transport (script_ConnectClose 2)
291− , testGen "ConnectSendClose" transport (script_ConnectSendClose 2)
336+basicTests :: (Transport, TransportInternals) -> Int -> (Gen Script -> Gen Script) -> [Test]
337+basicTests transport numEndPoints trans = [
338+ testGen "NewEndPoint" transport (trans (script_NewEndPoint numEndPoints))
339+ , testGen "Connect" transport (trans (script_Connect numEndPoints))
340+ , testGen "ConnectClose" transport (trans (script_ConnectClose numEndPoints))
341+ , testGen "ConnectSendClose" transport (trans (script_ConnectSendClose numEndPoints))
292342 ]
293343
294−tests :: Transport -> [Test]
344+tests :: (Transport, TransportInternals) -> [Test]
295345tests transport = [
296346 testGroup "Bugs" [
297347 testOne "Bug1" transport script_Bug1
298348 ]
299− , testGroup "One endpoint, with delays" (basicTests transport 1)
300− , testGroup "Two endpoints, with delays" (basicTests transport 2)
301− , testGroup "Three endpoints, with delays" (basicTests transport 3)
349+ , testGroup "One endpoint, with delays" (basicTests transport 1 id)
350+ , testGroup "Two endpoints, with delays" (basicTests transport 2 id)
351+ , testGroup "Three endpoints, with delays" (basicTests transport 3 id)
352+ , testGroup "Four endpoints, with delay, single error" (basicTests transport 4 (withErrors 1))
302353 ]
303354 where
304355
305−testOne :: TestName -> Transport -> Script -> Test
356+testOne :: TestName -> (Transport, TransportInternals) -> Script -> Test
306357testOne label transport script = testCase label (testScript transport script)
307358
308−testGen :: TestName -> Transport -> Gen Script -> Test
359+testGen :: TestName -> (Transport, TransportInternals) -> Gen Script -> Test
309360testGen label transport script = testProperty label (testScriptGen transport script)
310361
311362main :: IO ()
312363main = do
313− Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
364+ Right transport <- createTransportExposeInternals "127.0.0.1" "8080" defaultTCPParameters
314365 defaultMain (tests transport)
315366
316367--------------------------------------------------------------------------------
317368-- Test infrastructure --
318369--------------------------------------------------------------------------------
319370
320−testScriptGen :: Transport -> Gen Script -> Property
371+testScriptGen :: (Transport, TransportInternals) -> Gen Script -> Property
321372testScriptGen transport scriptGen =
322373 forAll scriptGen $ \script ->
323374 morallyDubiousIOProperty $ do
@@ -330,7 +381,7 @@ testScriptGen transport scriptGen =
330381 , reason = '\n' : err ++ "\nAll events: " ++ show evs
331382 }
332383
333−testScript :: Transport -> Script -> Assertion
384+testScript :: (Transport, TransportInternals) -> Script -> Assertion
334385testScript transport script = do
335386 logShow script
336387 evs <- execScript transport script