@@ -5,6 +5,7 @@ module Main
55 , logShow
66 , forAllShrink
77 , inits
8+ , expectedFailure
89 ) where
910
1011import Prelude hiding (log)
@@ -29,8 +30,8 @@ import Control.Arrow (second)
2930import Control.Applicative ((<$>))
3031import Control.Exception (Exception, throwIO, try)
3132import Control.Concurrent (forkIO, threadDelay, ThreadId, killThread)
32−import Control.Monad (replicateM, forever, guard)
33−import Control.Monad.State.Lazy (StateT, execStateT)
33+import Control.Monad (MonadPlus(..), replicateM, forever, guard)
34+import Control.Monad.State (StateT, execStateT)
3435import Control.Monad.IO.Class (MonadIO, liftIO)
3536import Data.Typeable (Typeable)
3637import Data.Maybe (isJust)
@@ -38,19 +39,22 @@ import Data.List (inits)
3839import Data.ByteString (ByteString)
3940import Data.ByteString.Char8 (pack)
4041import Data.Accessor (Accessor, accessor, (^.))
41−import Data.Accessor.Monad.Trans.State (get, modify)
42−import qualified Data.Accessor.Container as DAC (mapDefault)
42+import Data.Accessor.Monad.Trans.State (get, set, modify)
43+import qualified Data.Accessor.Container as DAC (set, mapDefault)
4344import qualified Data.ByteString as BSS (concat)
4445import qualified Text.PrettyPrint as PP
4546import Data.Unique (Unique, newUnique, hashUnique)
4647import Data.Concurrent.Queue.MichaelScott (newQ, pushL, tryPopR)
48+import Data.Set (Set)
49+import qualified Data.Set as Set
4750
4851import Network.Transport
4952import Network.Transport.TCP
5053 ( createTransportExposeInternals
5154 , defaultTCPParameters
52− , TransportInternals
55+ , TransportInternals(socketBetween)
5356 )
57+import Network.Transport.TCP.Mock.Socket (scheduleReadAction, sClose)
5458
5559--------------------------------------------------------------------------------
5660-- Script infrastructure --
@@ -99,31 +103,46 @@ instance Show a => Show (Variable a) where
99103 show (Value x) = show x
100104 show (Variable u) = "<<" ++ show (hashUnique u) ++ ">>"
101105
106+type BundleId = Int
107+
108+data ConnectionInfo = ConnectionInfo {
109+ source :: EndPointAddress
110+ , target :: EndPointAddress
111+ , connectionId :: Variable ConnectionId
112+ , bundleId :: BundleId
113+ }
114+ deriving Show
115+
102116data ExpEvent =
103− ExpConnectionOpened (Variable ConnectionId)
104− | ExpConnectionClosed (Variable ConnectionId)
105− | ExpReceived (Variable ConnectionId) [ByteString]
117+ ExpConnectionOpened ConnectionInfo
118+ | ExpConnectionClosed ConnectionInfo
119+ | ExpReceived ConnectionInfo [ByteString]
120+ | ExpConnectionLost BundleId EndPointAddress
106121 deriving Show
107122
108−type TargetAddress = EndPointAddress
109−
110123data RunState = RunState {
111124 _endPoints :: [EndPoint]
112− , _connections :: [(TargetAddress, Connection, Variable ConnectionId)]
125+ , _connections :: [(Connection, ConnectionInfo)]
113126 , _expectedEvents :: Map EndPointAddress [ExpEvent]
114127 , _forwardingThreads :: [ThreadId]
128+ , _mayBreak :: Set BundleId
129+ , _broken :: Set BundleId
130+ , _currentBundle :: BundleId
115131 }
116132
117133initialRunState :: RunState
118134initialRunState = RunState {
119− _endPoints = []
120− , _connections = []
121− , _expectedEvents = Map.empty
135+ _endPoints = []
136+ , _connections = []
137+ , _expectedEvents = Map.empty
122138 , _forwardingThreads = []
139+ , _mayBreak = Set.empty
140+ , _broken = Set.empty
141+ , _currentBundle = 0
123142 }
124143
125144verify :: (Transport, TransportInternals) -> Script -> IO (Either String ())
126−verify (transport, _transportInternals) script = do
145+verify (transport, transportInternals) script = do
127146 allEvents <- newQ
128147
129148 let runScript :: Script -> StateT RunState IO ()
@@ -145,24 +164,57 @@ verify (transport, _transportInternals) script = do
145164 mConn <- liftIO $ connect endPointA endPointB ReliableOrdered defaultConnectHints
146165 case mConn of
147166 Right conn -> do
167+ bundleBroken <- get currentBundle >>= get . broken
168+ currentBundleId <- if bundleBroken
169+ then modify currentBundle (+ 1) >> get currentBundle
170+ else get currentBundle
148171 connId <- Variable <$> liftIO newUnique
149− modify connections (snoc (endPointB, conn, connId))
150− modify (expectedEventsAt endPointB) (snoc (ExpConnectionOpened connId))
151− Left err ->
152− liftIO $ throwIO err
172+ let connInfo = ConnectionInfo {
173+ source = address endPointA
174+ , target = endPointB
175+ , connectionId = connId
176+ , bundleId = currentBundleId
177+ }
178+ modify connections (snoc (conn, connInfo))
179+ modify (expectedEventsAt endPointB) (snoc (ExpConnectionOpened connInfo))
180+ Left err -> do
181+ currentBundleId <- get currentBundle
182+ expectingBreak <- get $ mayBreak currentBundleId
183+ if expectingBreak
184+ then do
185+ set (mayBreak currentBundleId) False
186+ set (broken currentBundleId) True
187+ else
188+ liftIO $ throwIO err
153189 runCmd (Close i) = do
154− (target, conn, connId) <- get (connectionAt i)
155− liftIO $ close conn
156− modify (expectedEventsAt target) (snoc (ExpConnectionClosed connId))
190+ (conn, connInfo) <- get (connectionAt i)
191+ liftIO $ close conn
192+ modify (expectedEventsAt (target connInfo)) (snoc (ExpConnectionClosed connInfo))
157193 runCmd (Send i payload) = do
158− (target, conn, connId) <- get (connectionAt i)
194+ (conn, connInfo) <- get (connectionAt i)
159195 mResult <- liftIO $ send conn payload
160196 case mResult of
161197 Right () -> return ()
162− Left err -> liftIO $ throwIO err
163− modify (expectedEventsAt target) (snoc (ExpReceived connId payload))
164− runCmd (BreakAfterReads _n _i _j) =
165− expectedFailure "BreakAfterReads not implemented"
198+ Left err -> do
199+ expectingBreak <- get $ mayBreak (bundleId connInfo)
200+ isBroken <- get $ broken (bundleId connInfo)
201+ if expectingBreak || isBroken
202+ then do
203+ set (mayBreak (bundleId connInfo)) False
204+ set (broken (bundleId connInfo)) True
205+ else
206+ liftIO $ throwIO err
207+ modify (expectedEventsAt (target connInfo)) (snoc (ExpReceived connInfo payload))
208+ runCmd (BreakAfterReads n i j) = do
209+ endPointA <- address <$> get (endPointAtIx i)
210+ endPointB <- address <$> get (endPointAtIx j)
211+ liftIO $ do
212+ sock <- socketBetween transportInternals endPointA endPointB
213+ scheduleReadAction sock n (sClose sock)
214+ currentBundleId <- get currentBundle
215+ set (mayBreak currentBundleId) True
216+ modify (expectedEventsAt endPointA) (snoc (ExpConnectionLost currentBundleId endPointB))
217+ modify (expectedEventsAt endPointB) (snoc (ExpConnectionLost currentBundleId endPointA))
166218
167219 forward :: EndPoint -> IO ()
168220 forward endPoint = forever $ do
@@ -185,7 +237,7 @@ verify (transport, _transportInternals) script = do
185237 st <- execStateT (runScript script) initialRunState
186238 actualEvents <- collectEvents st
187239
188− let eventsMatch = and . map (uncurry match) $
240+ let eventsMatch = all (uncurry match) $
189241 zip (Map.elems (st ^. expectedEvents))
190242 (Map.elems actualEvents)
191243
@@ -201,68 +253,111 @@ verify (transport, _transportInternals) script = do
201253-- | Match a list of expected events to a list of actual events, taking into
202254-- account that events may be reordered
203255match :: [ExpEvent] -> [Event] -> Bool
204−match expected actual = or (map (isJust . flip unify actual) (reorder expected))
205−
206−-- | Match a list of expected events to a list of actual events, without doing
207−-- reordering
208−unify :: [ExpEvent] -> [Event] -> Maybe ()
209−unify [] [] = return ()
210−unify (ExpConnectionOpened connId : expected) (ConnectionOpened connId' _ _ : actual) = do
211− subst <- unifyConnectionId connId connId'
212− unify (apply subst expected) actual
213−unify (ExpConnectionClosed connId : expected) (ConnectionClosed connId' : actual) = do
214− subst <- unifyConnectionId connId connId'
215− unify (apply subst expected) actual
216−unify (ExpReceived connId payload : expected) (Received connId' payload' : actual) = do
217− guard (BSS.concat payload == BSS.concat payload')
218− subst <- unifyConnectionId connId connId'
219− unify (apply subst expected) actual
220−unify _ _ = fail "Cannot unify"
221−
222−type Substitution a = Map Unique a
223−
224−-- | Match two connection IDs
225−unifyConnectionId :: Variable ConnectionId -> ConnectionId -> Maybe (Substitution ConnectionId)
226−unifyConnectionId (Variable x) connId = Just $ Map.singleton x connId
227−unifyConnectionId (Value connId') connId | connId == connId' = Just Map.empty
228− | otherwise = Nothing
229−
230−-- | Apply a substitution
231−apply :: Substitution ConnectionId -> [ExpEvent] -> [ExpEvent]
232−apply subst = map applyEvent
233− where
234− applyEvent :: ExpEvent -> ExpEvent
235− applyEvent (ExpConnectionOpened connId) = ExpConnectionOpened (applyVar connId)
236− applyEvent (ExpConnectionClosed connId) = ExpConnectionClosed (applyVar connId)
237− applyEvent (ExpReceived connId payload) = ExpReceived (applyVar connId) payload
238−
239− applyVar :: Variable ConnectionId -> Variable ConnectionId
240− applyVar (Value connId) = Value connId
241− applyVar (Variable x) = case Map.lookup x subst of
242− Just connId -> Value connId
243− Nothing -> Variable x
244−
245−-- | Return all possible reorderings of a list of expected events
246−--
247−-- Events from different connections can be reordered, but events from the
248−-- same connection cannot.
249−reorder :: [ExpEvent] -> [[ExpEvent]]
250−reorder = go
256+match expected actual = any (`canUnify` actual) (possibleTraces expected)
257+
258+possibleTraces :: [ExpEvent] -> [[ExpEvent]]
259+possibleTraces = go
251260 where
252− go :: [ExpEvent] -> [[ExpEvent]]
253− go [] = [[]]
254− go (ev : evs) = concat [insert ev evs' | evs' <- reorder evs]
261+ go [] = [[]]
262+ go (ev@(ExpConnectionLost _ _) : evs) =
263+ [ trace | evs' <- possibleTraces evs, trace <- insertConnectionLost ev evs' ]
264+ go (ev : evs) =
265+ [ trace | evs' <- possibleTraces evs, trace <- insertEvent ev evs' ]
266+
267+ -- We don't know when exactly the error will occur (indeed, it may never
268+ -- happen at all), but it must occur before any future connection lost
269+ -- event to the same destination.
270+ -- If it occurs now, then all other events on this bundle will not happen.
271+ insertConnectionLost :: ExpEvent -> [ExpEvent] -> [[ExpEvent]]
272+ insertConnectionLost ev [] = [[ev], []]
273+ insertConnectionLost ev@(ExpConnectionLost bid addr) (ev' : evs) =
274+ (ev : removeBundle bid (ev' : evs)) :
275+ case ev' of
276+ ExpConnectionLost _ addr' | addr == addr' -> []
277+ _ -> [ev' : evs' | evs' <- insertConnectionLost ev evs]
278+ insertConnectionLost _ _ = error "The impossible happened"
279+
280+ -- All other events can be arbitrarily reordered /across/ connections, but
281+ -- never /within/ connections
282+ insertEvent :: ExpEvent -> [ExpEvent] -> [[ExpEvent]]
283+ insertEvent ev [] = [[ev]]
284+ insertEvent ev (ev' : evs) =
285+ (ev : ev' : evs) :
286+ if eventConnId ev == eventConnId ev'
287+ then []
288+ else [ev' : evs' | evs' <- insertEvent ev evs]
289+
290+ removeBundle :: BundleId -> [ExpEvent] -> [ExpEvent]
291+ removeBundle bid = filter ((/= bid) . eventBundleId)
292+
293+ eventBundleId :: ExpEvent -> BundleId
294+ eventBundleId (ExpConnectionOpened connInfo) = bundleId connInfo
295+ eventBundleId (ExpConnectionClosed connInfo) = bundleId connInfo
296+ eventBundleId (ExpReceived connInfo _) = bundleId connInfo
297+ eventBundleId (ExpConnectionLost bid _) = bid
298+
299+ eventConnId :: ExpEvent -> Maybe (Variable ConnectionId)
300+ eventConnId (ExpConnectionOpened connInfo) = Just $ connectionId connInfo
301+ eventConnId (ExpConnectionClosed connInfo) = Just $ connectionId connInfo
302+ eventConnId (ExpReceived connInfo _) = Just $ connectionId connInfo
303+ eventConnId (ExpConnectionLost _ _) = Nothing
255304
256− insert :: ExpEvent -> [ExpEvent] -> [[ExpEvent]]
257− insert ev [] = [[ev]]
258− insert ev (ev' : evs')
259− | connectionId ev == connectionId ev' = [ev : ev' : evs']
260− | otherwise = (ev : ev' : evs') : [ev' : evs'' | evs'' <- insert ev evs']
305+--------------------------------------------------------------------------------
306+-- Unification --
307+--------------------------------------------------------------------------------
261308
262− connectionId :: ExpEvent -> Variable ConnectionId
263− connectionId (ExpConnectionOpened connId) = connId
264− connectionId (ExpConnectionClosed connId) = connId
265− connectionId (ExpReceived connId _) = connId
309+type Substitution = Map Unique ConnectionId
310+
311+newtype Unifier a = Unifier {
312+ runUnifier :: Substitution -> Maybe (a, Substitution)
313+ }
314+
315+instance Monad Unifier where
316+ return x = Unifier $ \subst -> Just (x, subst)
317+ x >>= f = Unifier $ \subst -> case runUnifier x subst of
318+ Nothing -> Nothing
319+ Just (a, subst') -> runUnifier (f a) subst'
320+ fail _str = mzero
321+
322+instance MonadPlus Unifier where
323+ mzero = Unifier $ const Nothing
324+ f `mplus` g = Unifier $ \subst -> case runUnifier f subst of
325+ Nothing -> runUnifier g subst
326+ Just (a, subst') -> Just (a, subst')
327+
328+class Unify a b where
329+ unify :: a -> b -> Unifier ()
330+
331+canUnify :: Unify a b => a -> b -> Bool
332+canUnify a b = isJust $ runUnifier (unify a b) Map.empty
333+
334+instance Unify Unique ConnectionId where
335+ unify x cid = Unifier $ \subst ->
336+ case Map.lookup x subst of
337+ Just cid' -> if cid == cid' then Just ((), subst)
338+ else Nothing
339+ Nothing -> Just ((), Map.insert x cid subst)
340+
341+instance Unify (Variable ConnectionId) ConnectionId where
342+ unify (Variable x) connId = unify x connId
343+ unify (Value connId') connId = guard $ connId' == connId
344+
345+instance Unify ExpEvent Event where
346+ unify (ExpConnectionOpened connInfo) (ConnectionOpened connId _ _) =
347+ unify (connectionId connInfo) connId
348+ unify (ExpConnectionClosed connInfo) (ConnectionClosed connId) =
349+ unify (connectionId connInfo) connId
350+ unify (ExpReceived connInfo payload) (Received connId payload') = do
351+ guard $ BSS.concat payload == BSS.concat payload'
352+ unify (connectionId connInfo) connId
353+ unify (ExpConnectionLost _ addr) (ErrorEvent (TransportError (EventConnectionLost addr') _)) =
354+ guard $ addr == addr'
355+ unify _ _ = fail "Cannot unify"
356+
357+instance Unify a b => Unify [a] [b] where
358+ unify [] [] = return ()
359+ unify (x:xs) (y:ys) = unify x y >> unify xs ys
360+ unify _ _ = fail "Cannot unify"
266361
267362--------------------------------------------------------------------------------
268363-- Script generators --
@@ -360,7 +455,7 @@ withErrors numErrors gen = gen >>= insertError numErrors
360455 insert <- arbitrary
361456 if insert && n > 0
362457 then do
363− numReads <- chooseFrom' (NormalD { mean = 5, stdDev = 10 }) (0, 100)
458+ numReads <- chooseFrom' NormalD { mean = 5, stdDev = 10 } (0, 100)
364459 swap <- arbitrary
365460 if swap
366461 then return $ Connect i j : BreakAfterReads numReads j i : cmds
@@ -529,10 +624,10 @@ endPoints = accessor _endPoints (\es st -> st { _endPoints = es })
529624endPointAtIx :: EndPointIx -> Accessor RunState EndPoint
530625endPointAtIx i = endPoints >>> listAccessor i
531626
532−connections :: Accessor RunState [(TargetAddress, Connection, Variable ConnectionId)]
627+connections :: Accessor RunState [(Connection, ConnectionInfo)]
533628connections = accessor _connections (\cs st -> st { _connections = cs })
534629
535−connectionAt :: ConnectionIx -> Accessor RunState (TargetAddress, Connection, Variable ConnectionId)
630+connectionAt :: ConnectionIx -> Accessor RunState (Connection, ConnectionInfo)
536631connectionAt i = connections >>> listAccessor i
537632
538633expectedEvents :: Accessor RunState (Map EndPointAddress [ExpEvent])
@@ -544,6 +639,21 @@ expectedEventsAt addr = expectedEvents >>> DAC.mapDefault [] addr
544639forwardingThreads :: Accessor RunState [ThreadId]
545640forwardingThreads = accessor _forwardingThreads (\ts st -> st { _forwardingThreads = ts })
546641
642+mayBreak :: BundleId -> Accessor RunState Bool
643+mayBreak bid = aux >>> DAC.set bid
644+ where
645+ aux :: Accessor RunState (Set BundleId)
646+ aux = accessor _mayBreak (\bs st -> st { _mayBreak = bs })
647+
648+broken :: BundleId -> Accessor RunState Bool
649+broken bid = aux >>> DAC.set bid
650+ where
651+ aux :: Accessor RunState (Set BundleId)
652+ aux = accessor _broken (\bs st -> st { _broken = bs })
653+
654+currentBundle :: Accessor RunState BundleId
655+currentBundle = accessor _currentBundle (\bid st -> st { _currentBundle = bid })
656+
547657--------------------------------------------------------------------------------
548658-- Pretty-printing --
549659--------------------------------------------------------------------------------
@@ -603,7 +713,7 @@ logShow = log . show
603713
604714instance Arbitrary ByteString where
605715 arbitrary = do
606− len <- chooseFrom' (NormalD { mean = 5, stdDev = 10 }) (0, 100)
716+ len <- chooseFrom' NormalD { mean = 5, stdDev = 10 } (0, 100)
607717 xs <- replicateM len arbitrary
608718 return (pack xs)
609719