@@ -5,6 +5,7 @@ module Main
6 , forAllShrink
6 , forAllShrink
10import Prelude hiding (log)
11import Prelude hiding (log)
@@ -29,8 +30,8 @@ import Control.Arrow (second)
29import Control.Applicative ((<$>))
30import Control.Applicative ((<$>))
30import Control.Exception (Exception, throwIO, try)
31import Control.Exception (Exception, throwIO, try)
31import Control.Concurrent (forkIO, threadDelay, ThreadId, killThread)
32import Control.Concurrent (forkIO, threadDelay, ThreadId, killThread)
32−import Control.Monad (replicateM, forever, guard)
33+import Control.Monad (MonadPlus(..), replicateM, forever, guard)
33−import Control.Monad.State.Lazy (StateT, execStateT)
34+import Control.Monad.State (StateT, execStateT)
34import Control.Monad.IO.Class (MonadIO, liftIO)
35import Control.Monad.IO.Class (MonadIO, liftIO)
35import Data.Typeable (Typeable)
36import Data.Typeable (Typeable)
36import Data.Maybe (isJust)
37import Data.Maybe (isJust)
@@ -38,19 +39,22 @@ import Data.List (inits)
38import Data.ByteString (ByteString)
39import Data.ByteString (ByteString)
39import Data.ByteString.Char8 (pack)
40import Data.ByteString.Char8 (pack)
40import Data.Accessor (Accessor, accessor, (^.))
41import Data.Accessor (Accessor, accessor, (^.))
41−import Data.Accessor.Monad.Trans.State (get, modify)
42+import Data.Accessor.Monad.Trans.State (get, set, modify)
42−import qualified Data.Accessor.Container as DAC (mapDefault)
43+import qualified Data.Accessor.Container as DAC (set, mapDefault)
43import qualified Data.ByteString as BSS (concat)
44import qualified Data.ByteString as BSS (concat)
44import qualified Text.PrettyPrint as PP
45import qualified Text.PrettyPrint as PP
45import Data.Unique (Unique, newUnique, hashUnique)
46import Data.Unique (Unique, newUnique, hashUnique)
46import Data.Concurrent.Queue.MichaelScott (newQ, pushL, tryPopR)
47import Data.Concurrent.Queue.MichaelScott (newQ, pushL, tryPopR)
49+import qualified Data.Set as Set
48import Network.Transport
51import Network.Transport
49import Network.Transport.TCP
52import Network.Transport.TCP
50 ( createTransportExposeInternals
53 ( createTransportExposeInternals
51 , defaultTCPParameters
54 , defaultTCPParameters
52− , TransportInternals
55+ , TransportInternals(socketBetween)
57+import Network.Transport.TCP.Mock.Socket (scheduleReadAction, sClose)
55--------------------------------------------------------------------------------
59--------------------------------------------------------------------------------
56-- Script infrastructure --
60-- Script infrastructure --
@@ -99,31 +103,46 @@ instance Show a => Show (Variable a) where
99 show (Value x) = show x
103 show (Value x) = show x
100 show (Variable u) = "<<" ++ show (hashUnique u) ++ ">>"
104 show (Variable u) = "<<" ++ show (hashUnique u) ++ ">>"
108+data ConnectionInfo = ConnectionInfo {
109+ source :: EndPointAddress
110+ , target :: EndPointAddress
111+ , connectionId :: Variable ConnectionId
112+ , bundleId :: BundleId
102data ExpEvent =
116data ExpEvent =
103− ExpConnectionOpened (Variable ConnectionId)
117+ ExpConnectionOpened ConnectionInfo
104− | ExpConnectionClosed (Variable ConnectionId)
118+ | ExpConnectionClosed ConnectionInfo
105− | ExpReceived (Variable ConnectionId) [ByteString]
119+ | ExpReceived ConnectionInfo [ByteString]
120+ | ExpConnectionLost BundleId EndPointAddress
106 deriving Show
121 deriving Show
108−type TargetAddress = EndPointAddress
110data RunState = RunState {
123data RunState = RunState {
111 _endPoints :: [EndPoint]
124 _endPoints :: [EndPoint]
112− , _connections :: [(TargetAddress, Connection, Variable ConnectionId)]
125+ , _connections :: [(Connection, ConnectionInfo)]
113 , _expectedEvents :: Map EndPointAddress [ExpEvent]
126 , _expectedEvents :: Map EndPointAddress [ExpEvent]
114 , _forwardingThreads :: [ThreadId]
127 , _forwardingThreads :: [ThreadId]
128+ , _mayBreak :: Set BundleId
129+ , _broken :: Set BundleId
130+ , _currentBundle :: BundleId
117initialRunState :: RunState
133initialRunState :: RunState
118initialRunState = RunState {
134initialRunState = RunState {
119− _endPoints = []
135+ _endPoints = []
120− , _connections = []
136+ , _connections = []
121− , _expectedEvents = Map.empty
137+ , _expectedEvents = Map.empty
122 , _forwardingThreads = []
138 , _forwardingThreads = []
139+ , _mayBreak = Set.empty
140+ , _broken = Set.empty
141+ , _currentBundle = 0
125verify :: (Transport, TransportInternals) -> Script -> IO (Either String ())
144verify :: (Transport, TransportInternals) -> Script -> IO (Either String ())
126−verify (transport, _transportInternals) script = do
145+verify (transport, transportInternals) script = do
127 allEvents <- newQ
146 allEvents <- newQ
129 let runScript :: Script -> StateT RunState IO ()
148 let runScript :: Script -> StateT RunState IO ()
@@ -145,24 +164,57 @@ verify (transport, _transportInternals) script = do
145 mConn <- liftIO $ connect endPointA endPointB ReliableOrdered defaultConnectHints
164 mConn <- liftIO $ connect endPointA endPointB ReliableOrdered defaultConnectHints
146 case mConn of
165 case mConn of
147 Right conn -> do
166 Right conn -> do
167+ bundleBroken <- get currentBundle >>= get . broken
168+ currentBundleId <- if bundleBroken
169+ then modify currentBundle (+ 1) >> get currentBundle
170+ else get currentBundle
148 connId <- Variable <$> liftIO newUnique
171 connId <- Variable <$> liftIO newUnique
172+ let connInfo = ConnectionInfo {
173+ source = address endPointA
174+ , target = endPointB
175+ , connectionId = connId
176+ , bundleId = currentBundleId
149− modify connections (snoc (endPointB, conn, connId))
178+ modify connections (snoc (conn, connInfo))
150− modify (expectedEventsAt endPointB) (snoc (ExpConnectionOpened connId))
179+ modify (expectedEventsAt endPointB) (snoc (ExpConnectionOpened connInfo))
151− Left err ->
180+ Left err -> do
181+ currentBundleId <- get currentBundle
182+ expectingBreak <- get $ mayBreak currentBundleId
185+ set (mayBreak currentBundleId) False
186+ set (broken currentBundleId) True
152− liftIO $ throwIO err
188+ liftIO $ throwIO err
153 runCmd (Close i) = do
189 runCmd (Close i) = do
154− (target, conn, connId) <- get (connectionAt i)
190+ (conn, connInfo) <- get (connectionAt i)
155− liftIO $ close conn
191+ liftIO $ close conn
156− modify (expectedEventsAt target) (snoc (ExpConnectionClosed connId))
192+ modify (expectedEventsAt (target connInfo)) (snoc (ExpConnectionClosed connInfo))
157 runCmd (Send i payload) = do
193 runCmd (Send i payload) = do
158− (target, conn, connId) <- get (connectionAt i)
194+ (conn, connInfo) <- get (connectionAt i)
159 mResult <- liftIO $ send conn payload
195 mResult <- liftIO $ send conn payload
160 case mResult of
196 case mResult of
161 Right () -> return ()
197 Right () -> return ()
199+ expectingBreak <- get $ mayBreak (bundleId connInfo)
200+ isBroken <- get $ broken (bundleId connInfo)
201+ if expectingBreak || isBroken
203+ set (mayBreak (bundleId connInfo)) False
204+ set (broken (bundleId connInfo)) True
162− Left err -> liftIO $ throwIO err
206+ liftIO $ throwIO err
163− modify (expectedEventsAt target) (snoc (ExpReceived connId payload))
207+ modify (expectedEventsAt (target connInfo)) (snoc (ExpReceived connInfo payload))
164− runCmd (BreakAfterReads _n _i _j) =
208+ runCmd (BreakAfterReads n i j) = do
165− expectedFailure "BreakAfterReads not implemented"
209+ endPointA <- address <$> get (endPointAtIx i)
210+ endPointB <- address <$> get (endPointAtIx j)
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))
167 forward :: EndPoint -> IO ()
219 forward :: EndPoint -> IO ()
168 forward endPoint = forever $ do
220 forward endPoint = forever $ do
@@ -185,7 +237,7 @@ verify (transport, _transportInternals) script = do
185 st <- execStateT (runScript script) initialRunState
237 st <- execStateT (runScript script) initialRunState
186 actualEvents <- collectEvents st
238 actualEvents <- collectEvents st
188− let eventsMatch = and . map (uncurry match) $
240+ let eventsMatch = all (uncurry match) $
189 zip (Map.elems (st ^. expectedEvents))
241 zip (Map.elems (st ^. expectedEvents))
190 (Map.elems actualEvents)
242 (Map.elems actualEvents)
@@ -201,68 +253,111 @@ verify (transport, _transportInternals) script = do
201-- | Match a list of expected events to a list of actual events, taking into
253-- | Match a list of expected events to a list of actual events, taking into
202-- account that events may be reordered
254-- account that events may be reordered
203match :: [ExpEvent] -> [Event] -> Bool
255match :: [ExpEvent] -> [Event] -> Bool
204−match expected actual = or (map (isJust . flip unify actual) (reorder expected))
256+match expected actual = any (`canUnify` actual) (possibleTraces expected)
206−-- | Match a list of expected events to a list of actual events, without doing
258+possibleTraces :: [ExpEvent] -> [[ExpEvent]]
207−-- reordering
259+possibleTraces = go
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"
222−type Substitution a = Map Unique a
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
230−-- | Apply a substitution
231−apply :: Substitution ConnectionId -> [ExpEvent] -> [ExpEvent]
232−apply subst = map applyEvent
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
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
245−-- | Return all possible reorderings of a list of expected events
247−-- Events from different connections can be reordered, but events from the
248−-- same connection cannot.
249−reorder :: [ExpEvent] -> [[ExpEvent]]
262+ go (ev@(ExpConnectionLost _ _) : evs) =
263+ [ trace | evs' <- possibleTraces evs, trace <- insertConnectionLost ev evs' ]
265+ [ trace | evs' <- possibleTraces evs, trace <- insertEvent ev evs' ]
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.
252− go :: [ExpEvent] -> [[ExpEvent]]
271+ insertConnectionLost :: ExpEvent -> [ExpEvent] -> [[ExpEvent]]
253− go [] = [[]]
272+ insertConnectionLost ev [] = [[ev], []]
254− go (ev : evs) = concat [insert ev evs' | evs' <- reorder evs]
273+ insertConnectionLost ev@(ExpConnectionLost bid addr) (ev' : evs) =
274+ (ev : removeBundle bid (ev' : evs)) :
276+ ExpConnectionLost _ addr' | addr == addr' -> []
277+ _ -> [ev' : evs' | evs' <- insertConnectionLost ev evs]
278+ insertConnectionLost _ _ = error "The impossible happened"
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) =
286+ if eventConnId ev == eventConnId ev'
288+ else [ev' : evs' | evs' <- insertEvent ev evs]
290+ removeBundle :: BundleId -> [ExpEvent] -> [ExpEvent]
291+ removeBundle bid = filter ((/= bid) . eventBundleId)
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
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
256− insert :: ExpEvent -> [ExpEvent] -> [[ExpEvent]]
305+--------------------------------------------------------------------------------
257− insert ev [] = [[ev]]
306+-- Unification --
258− insert ev (ev' : evs')
307+--------------------------------------------------------------------------------
259− | connectionId ev == connectionId ev' = [ev : ev' : evs']
260− | otherwise = (ev : ev' : evs') : [ev' : evs'' | evs'' <- insert ev evs']
262− connectionId :: ExpEvent -> Variable ConnectionId
309+type Substitution = Map Unique ConnectionId
311+newtype Unifier a = Unifier {
312+ runUnifier :: Substitution -> Maybe (a, Substitution)
315+instance Monad Unifier where
316+ return x = Unifier $ \subst -> Just (x, subst)
317+ x >>= f = Unifier $ \subst -> case runUnifier x subst of
319+ Just (a, subst') -> runUnifier (f a) subst'
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')
328+class Unify a b where
329+ unify :: a -> b -> Unifier ()
331+canUnify :: Unify a b => a -> b -> Bool
332+canUnify a b = isJust $ runUnifier (unify a b) Map.empty
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)
339+ Nothing -> Just ((), Map.insert x cid subst)
341+instance Unify (Variable ConnectionId) ConnectionId where
342+ unify (Variable x) connId = unify x connId
343+ unify (Value connId') connId = guard $ connId' == connId
345+instance Unify ExpEvent Event where
263− connectionId (ExpConnectionOpened connId) = connId
346+ unify (ExpConnectionOpened connInfo) (ConnectionOpened connId _ _) =
347+ unify (connectionId connInfo) connId
264− connectionId (ExpConnectionClosed connId) = connId
348+ unify (ExpConnectionClosed connInfo) (ConnectionClosed connId) =
265− connectionId (ExpReceived connId _) = 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"
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"
267--------------------------------------------------------------------------------
362--------------------------------------------------------------------------------
268-- Script generators --
363-- Script generators --
@@ -360,7 +455,7 @@ withErrors numErrors gen = gen >>= insertError numErrors
360 insert <- arbitrary
455 insert <- arbitrary
361 if insert && n > 0
456 if insert && n > 0
363− numReads <- chooseFrom' (NormalD { mean = 5, stdDev = 10 }) (0, 100)
458+ numReads <- chooseFrom' NormalD { mean = 5, stdDev = 10 } (0, 100)
364 swap <- arbitrary
459 swap <- arbitrary
366 then return $ Connect i j : BreakAfterReads numReads j i : cmds
461 then return $ Connect i j : BreakAfterReads numReads j i : cmds
@@ -529,10 +624,10 @@ endPoints = accessor _endPoints (\es st -> st { _endPoints = es })
529endPointAtIx :: EndPointIx -> Accessor RunState EndPoint
624endPointAtIx :: EndPointIx -> Accessor RunState EndPoint
530endPointAtIx i = endPoints >>> listAccessor i
625endPointAtIx i = endPoints >>> listAccessor i
532−connections :: Accessor RunState [(TargetAddress, Connection, Variable ConnectionId)]
627+connections :: Accessor RunState [(Connection, ConnectionInfo)]
533connections = accessor _connections (\cs st -> st { _connections = cs })
628connections = accessor _connections (\cs st -> st { _connections = cs })
535−connectionAt :: ConnectionIx -> Accessor RunState (TargetAddress, Connection, Variable ConnectionId)
630+connectionAt :: ConnectionIx -> Accessor RunState (Connection, ConnectionInfo)
536connectionAt i = connections >>> listAccessor i
631connectionAt i = connections >>> listAccessor i
538expectedEvents :: Accessor RunState (Map EndPointAddress [ExpEvent])
633expectedEvents :: Accessor RunState (Map EndPointAddress [ExpEvent])
@@ -544,6 +639,21 @@ expectedEventsAt addr = expectedEvents >>> DAC.mapDefault [] addr
544forwardingThreads :: Accessor RunState [ThreadId]
639forwardingThreads :: Accessor RunState [ThreadId]
545forwardingThreads = accessor _forwardingThreads (\ts st -> st { _forwardingThreads = ts })
640forwardingThreads = accessor _forwardingThreads (\ts st -> st { _forwardingThreads = ts })
642+mayBreak :: BundleId -> Accessor RunState Bool
643+mayBreak bid = aux >>> DAC.set bid
645+ aux :: Accessor RunState (Set BundleId)
646+ aux = accessor _mayBreak (\bs st -> st { _mayBreak = bs })
648+broken :: BundleId -> Accessor RunState Bool
649+broken bid = aux >>> DAC.set bid
651+ aux :: Accessor RunState (Set BundleId)
652+ aux = accessor _broken (\bs st -> st { _broken = bs })
654+currentBundle :: Accessor RunState BundleId
655+currentBundle = accessor _currentBundle (\bid st -> st { _currentBundle = bid })
547--------------------------------------------------------------------------------
657--------------------------------------------------------------------------------
548-- Pretty-printing --
658-- Pretty-printing --
549--------------------------------------------------------------------------------
659--------------------------------------------------------------------------------
@@ -603,7 +713,7 @@ logShow = log . show
604instance Arbitrary ByteString where
714instance Arbitrary ByteString where
605 arbitrary = do
715 arbitrary = do
606− len <- chooseFrom' (NormalD { mean = 5, stdDev = 10 }) (0, 100)
716+ len <- chooseFrom' NormalD { mean = 5, stdDev = 10 } (0, 100)
607 xs <- replicateM len arbitrary
717 xs <- replicateM len arbitrary
608 return (pack xs)
718 return (pack xs)