@@ -25,17 +25,24 @@ import Test.HUnit (Assertion, assertFailure)
25import Data.Map (Map)
25import Data.Map (Map)
26import qualified Data.Map as Map
26import qualified Data.Map as Map
27import Control.Category ((>>>))
27import Control.Category ((>>>))
28+import Control.Arrow (second)
28import Control.Applicative ((<$>))
29import Control.Applicative ((<$>))
29−import Control.Exception (Exception, throwIO)
30+import Control.Exception (throwIO)
30−import Control.Concurrent (forkIO, threadDelay)
31+import Control.Concurrent (forkIO, threadDelay, ThreadId, killThread)
31−import Control.Concurrent.Chan (Chan, newChan, writeChan, readChan)
32−import Control.Monad (replicateM, void)
32+import Control.Monad (replicateM, forever, guard)
33+import Control.Monad.State.Lazy (StateT, execStateT)
34+import Control.Monad.IO.Class (liftIO)
35+import Data.Maybe (isJust)
33−import Data.List (inits, delete)
36+import Data.List (inits)
34import Data.ByteString (ByteString)
37import Data.ByteString (ByteString)
35import Data.ByteString.Char8 (pack)
38import Data.ByteString.Char8 (pack)
36−import Data.Accessor (Accessor, accessor, (^:), (^.), (^=))
39+import Data.Accessor (Accessor, accessor, (^.))
40+import Data.Accessor.Monad.Trans.State (get, modify)
41+import qualified Data.Accessor.Container as DAC (mapDefault)
37import qualified Data.ByteString as BSS (concat)
42import qualified Data.ByteString as BSS (concat)
38import qualified Text.PrettyPrint as PP
43import qualified Text.PrettyPrint as PP
44+import Data.Unique (Unique, newUnique, hashUnique)
45+import Data.Concurrent.Queue.MichaelScott (newQ, pushL, tryPopR)
40import Network.Transport
47import Network.Transport
41import Network.Transport.TCP
48import Network.Transport.TCP
@@ -82,165 +89,179 @@ data ScriptCmd =
83type Script = [ScriptCmd]
90type Script = [ScriptCmd]
85−verticalList :: [PP.Doc] -> PP.Doc
92+--------------------------------------------------------------------------------
86−verticalList = PP.brackets . PP.vcat
93+-- Execute and verify scripts --
94+--------------------------------------------------------------------------------
88−eventsDoc :: Map Int [Event] -> PP.Doc
96+data Variable a = Value a | Variable Unique
89−eventsDoc = verticalList . map aux . Map.toList
97+ deriving Eq
91− aux :: (Int, [Event]) -> PP.Doc
92− aux (i, evs) = PP.parens . PP.hsep . PP.punctuate PP.comma $ [PP.int i, verticalList (map (PP.text . show) evs)]
99+instance Show a => Show (Variable a) where
100+ show (Value x) = show x
101+ show (Variable u) = "<<" ++ show (hashUnique u) ++ ">>"
95−instance Show Script where
103+data ExpEvent =
96− show = ("\n" ++) . show . verticalList . map (PP.text . show)
104+ ExpConnectionOpened (Variable ConnectionId)
105+ | ExpConnectionClosed (Variable ConnectionId)
106+ | ExpReceived (Variable ConnectionId) [ByteString]
109+type TargetAddress = EndPointAddress
98−instance Show (Map Int [Event]) where
111+data RunState = RunState {
99− show = ("\n" ++) . show . eventsDoc
112+ _endPoints :: [EndPoint]
113+ , _connections :: [(TargetAddress, Connection, Variable ConnectionId)]
114+ , _expectedEvents :: Map EndPointAddress [ExpEvent]
115+ , _forwardingThreads :: [ThreadId]
118+initialRunState :: RunState
119+initialRunState = RunState {
122+ , _expectedEvents = Map.empty
123+ , _forwardingThreads = []
126+verify :: (Transport, TransportInternals) -> Script -> IO (Either String ())
127+verify (transport, transportInternals) script = do
130+ let runScript :: Script -> StateT RunState IO ()
131+ runScript = mapM_ runCmd
133+ runCmd :: ScriptCmd -> StateT RunState IO ()
134+ runCmd NewEndPoint = do
135+ mEndPoint <- liftIO $ newEndPoint transport
137+ Right endPoint -> do
138+ modify endPoints (snoc endPoint)
139+ tid <- liftIO $ forkIO (forward endPoint)
140+ modify forwardingThreads (tid :)
142+ liftIO $ throwIO err
143+ runCmd (Connect i j) = do
144+ endPointA <- get (endPointAtIx i)
145+ endPointB <- address <$> get (endPointAtIx j)
146+ mConn <- liftIO $ connect endPointA endPointB ReliableOrdered defaultConnectHints
149+ connId <- Variable <$> liftIO newUnique
150+ modify connections (snoc (endPointB, conn, connId))
151+ modify (expectedEventsAt endPointB) (snoc (ExpConnectionOpened connId))
153+ liftIO $ throwIO err
154+ runCmd (Close i) = do
155+ (target, conn, connId) <- get (connectionAt i)
157+ modify (expectedEventsAt target) (snoc (ExpConnectionClosed connId))
158+ runCmd (Send i payload) = do
159+ (target, conn, connId) <- get (connectionAt i)
160+ mResult <- liftIO $ send conn payload
162+ Right () -> return ()
163+ Left err -> liftIO $ throwIO err
164+ modify (expectedEventsAt target) (snoc (ExpReceived connId payload))
101−--------------------------------------------------------------------------------
166+ forward :: EndPoint -> IO ()
102−-- Execution --
167+ forward endPoint = forever $ do
103−--------------------------------------------------------------------------------
168+ ev <- receive endPoint
169+ pushL allEvents (address endPoint, ev)
105−-- | Execute a script
171+ collectEvents :: RunState -> IO (Map EndPointAddress [Event])
106−--
172+ collectEvents st = do
107−-- Execute ignores error codes reported back. Instead, we verify the events
109−execScript :: (Transport, TransportInternals) -> Script -> IO (Map EndPointIx [Event], VerificationState)
110−execScript (transport, transportInternals) script = do
112− vst <- runScript chan script
113− evs <- collectAll chan
116− runScript :: Chan (Maybe (EndPointIx, Event)) -> Script -> IO VerificationState
117− runScript chan = go [] []
119− go :: [EndPoint] -> [Either (TransportError ConnectErrorCode) Connection] -> Script -> IO VerificationState
120− go endPoints _conns [] = do
122− writeChan chan Nothing
123− return (initialVerificationState (map address endPoints))
124− go endPoints conns (NewEndPoint : cmds) = do
125− endPoint <- throwIfLeft $ newEndPoint transport
126− let endPointIx = length endPoints
127− _tid <- forkIO $ forwardTo chan (endPointIx, endPoint)
129− go (endPoint `snoc` endPoints) conns cmds
130− go endPoints conns (Connect fr to : cmds) = do
131− conn <- connect (endPoints !! fr) (address (endPoints !! to)) ReliableOrdered defaultConnectHints
132 threadDelay 10000
173 threadDelay 10000
133− go endPoints (conn `snoc` conns) cmds
174+ mapM_ killThread (st ^. forwardingThreads)
134− go endPoints conns (Close connIx : cmds) = do
175+ evs <- go []
135− case conns !! connIx of
176+ return (groupByKey evs)
136− Left _err -> return ()
177+ where
137− Right conn -> close conn
178+ go acc = do
138− threadDelay 10000
179+ mEv <- tryPopR allEvents
139− go endPoints conns cmds
140− go endPoints conns (Send connIx payload : cmds) = do
141− case conns !! connIx of
142− Left _err -> return ()
143− Right conn -> void $ send conn payload
145− go endPoints conns cmds
146− go endPoints conns (BreakAfterReads n i j : cmds) = do
147− sock <- socketBetween transportInternals (address (endPoints !! i)) (address (endPoints !! j))
148− scheduleReadAction sock n (putStrLn "Closing" >> sClose sock)
149− go endPoints conns cmds
151− forwardTo :: Chan (Maybe (EndPointIx, Event)) -> (EndPointIx, EndPoint) -> IO ()
152− forwardTo chan (ix, endPoint) = go
156− ev <- receive endPoint
157− case ev of
180+ case mEv of
158− EndPointClosed -> return ()
159− _ -> writeChan chan (Just (ix, ev)) >> go
181+ Just ev -> go (ev : acc)
160−
182+ Nothing -> return acc
161− collectAll :: Chan (Maybe (EndPointIx, Event)) -> IO (Map EndPointIx [Event])
183+
162− collectAll chan = go Map.empty
184+ st <- execStateT (runScript script) initialRunState
163− where
185+ actualEvents <- collectEvents st
164− go :: Map Int [Event] -> IO (Map Int [Event])
186+
165− go acc = do
187+ let eventsMatch = and . map (uncurry match) $
166− mEv <- readChan chan
188+ zip (Map.elems (st ^. expectedEvents))
167− case mEv of
189+ (Map.elems actualEvents)
168− Nothing -> return $ Map.map reverse acc
190+
169− Just (ix, ev) -> go (Map.alter (insertEvent ev) ix acc)
191+ return $ if eventsMatch
171− insertEvent :: Event -> Maybe [Event] -> Maybe [Event]
193+ else Left ("Could not match " ++ show (st ^. expectedEvents)
172− insertEvent ev Nothing = Just [ev]
194+ ++ " and " ++ show actualEvents)
173− insertEvent ev (Just evs) = Just (ev : evs)
175--------------------------------------------------------------------------------
196--------------------------------------------------------------------------------
176−-- Verification --
197+-- Match expected and actual events --
177--------------------------------------------------------------------------------
198--------------------------------------------------------------------------------
179−data VerificationState = VerificationState {
200+-- | Match a list of expected events to a list of actual events, taking into
180− endPointAddrs :: [EndPointAddress]
201+-- account that events may be reordered
181− , _connections :: [(SourceEndPointIx, TargetEndPointIx, ConnectionId)]
202+match :: [ExpEvent] -> [Event] -> Bool
182− , _mayBreak :: [(SourceEndPointIx, TargetEndPointIx)]
203+match expected actual = or (map (isJust . flip unify actual) (reorder expected))
184−
205+-- | Match a list of expected events to a list of actual events, without doing
185−initialVerificationState :: [EndPointAddress] -> VerificationState
206+-- reordering
186−initialVerificationState addrs = VerificationState {
207+unify :: [ExpEvent] -> [Event] -> Maybe ()
187− endPointAddrs = addrs
208+unify [] [] = return ()
188− , _connections = []
209+unify (ExpConnectionOpened connId : expected) (ConnectionOpened connId' _ _ : actual) = do
189− , _mayBreak = []
210+ subst <- unifyConnectionId connId connId'
190− }
211+ unify (apply subst expected) actual
191−
212+unify (ExpConnectionClosed connId : expected) (ConnectionClosed connId' : actual) = do
192−-- TODO: we currently have no way to verify addresses in ConnectionOpened
213+ subst <- unifyConnectionId connId connId'
193−-- or EventConnectionLost (because we don't know the addresses of the endpoints)
214+ unify (apply subst expected) actual
194−verify :: VerificationState -> Script -> Map EndPointIx [Event] -> Maybe String
215+unify (ExpReceived connId payload : expected) (Received connId' payload' : actual) = do
195−verify _st [] evs =
216+ guard (BSS.concat payload == BSS.concat payload')
196− -- TODO: we should compare the error events against mayBreak, but we
217+ subst <- unifyConnectionId connId connId'
197− -- cannot because we don't know the endpoint addresses
218+ unify (apply subst expected) actual
198− if removeErrorEvents (concat (Map.elems evs)) == []
219+unify _ _ = fail "Cannot unify"
200− else Just $ "Unexpected events: " ++ show evs
221+type Substitution a = Map Unique a
201−verify st (NewEndPoint : cmds) evs =
222+
202− verify st cmds evs
223+-- | Match two connection IDs
203−verify st (Connect fr to : cmds) evs =
224+unifyConnectionId :: Variable ConnectionId -> ConnectionId -> Maybe (Substitution ConnectionId)
204− case destruct evs to of
225+unifyConnectionId (Variable x) connId = Just $ Map.singleton x connId
205− Just (ConnectionOpened connId _rel _addr, evs') ->
226+unifyConnectionId (Value connId') connId | connId == connId' = Just Map.empty
206− verify (connections ^: snoc (fr, to, connId) $ st) cmds evs'
227+ | otherwise = Nothing
208− Just $ "Missing (ConnectionOpened <<connId>> <<rel>> <<addr>>). Got " ++ show ev
229+-- | Apply a substitution
209−verify st (Close connIx : cmds) evs =
230+apply :: Substitution ConnectionId -> [ExpEvent] -> [ExpEvent]
210− let (_fr, to, connId) = st ^. connectionAt connIx in
231+apply subst = map applyEvent
211− case destruct evs to of
232+ where
212− Just (ConnectionClosed connId', evs') | connId' == connId ->
233+ applyEvent :: ExpEvent -> ExpEvent
213− verify st cmds evs'
234+ applyEvent (ExpConnectionOpened connId) = ExpConnectionOpened (applyVar connId)
214− ev ->
235+ applyEvent (ExpConnectionClosed connId) = ExpConnectionClosed (applyVar connId)
215− Just $ "Missing (ConnectionClosed " ++ show connId ++ "). Got " ++ show ev
236+ applyEvent (ExpReceived connId payload) = ExpReceived (applyVar connId) payload
216−verify st (Send connIx payload : cmds) evs =
237+
217− let (fr, to, connId) = st ^. connectionAt connIx in
238+ applyVar :: Variable ConnectionId -> Variable ConnectionId
218− case destruct evs to of
239+ applyVar (Value connId) = Value connId
219− Just (Received connId' payload', evs') | connId' == connId && BSS.concat payload == BSS.concat payload' ->
240+ applyVar (Variable x) = case Map.lookup x subst of
220− verify st cmds evs'
241+ Just connId -> Value connId
221− Just (ErrorEvent (TransportError (EventConnectionLost _addr) _), evs') | st ^. mayBreak fr to ->
242+ Nothing -> Variable x
222− verify st cmds evs'
243+
223− ev ->
244+-- | Return all possible reorderings of a list of expected events
224− Just $ "Missing (Received " ++ show connId ++ " " ++ show payload ++ "). Got " ++ show ev
245+--
225−verify st (BreakAfterReads _n i j : cmds) evs =
246+-- Events from different connections can be reordered, but events from the
226− verify (mayBreak i j ^= True $ st) cmds evs
247+-- same connection cannot.
227−
248+reorder :: [ExpEvent] -> [[ExpEvent]]
228−connections :: Accessor VerificationState [(SourceEndPointIx, TargetEndPointIx, ConnectionId)]
249+reorder = go
229−connections = accessor _connections (\cs st -> st { _connections = cs })
250+ where
230−
251+ go :: [ExpEvent] -> [[ExpEvent]]
231−connectionAt :: ConnectionIx -> Accessor VerificationState (SourceEndPointIx, TargetEndPointIx, ConnectionId)
252+ go [] = [[]]
232−connectionAt i = connections >>> listAccessor i
253+ go (ev : evs) = concat [insert ev evs' | evs' <- reorder evs]
234−mayBreak :: EndPointIx -> EndPointIx -> Accessor VerificationState Bool
255+ insert :: ExpEvent -> [ExpEvent] -> [[ExpEvent]]
235−mayBreak i j = accessor
256+ insert ev [] = [[ev]]
236− (\st -> (i, j) `elem` _mayBreak st || (j, i) `elem` _mayBreak st)
257+ insert ev (ev' : evs')
237− (\b st -> if b then st { _mayBreak = (i, j) : _mayBreak st }
258+ | connectionId ev == connectionId ev' = [ev : ev' : evs']
238− else st { _mayBreak = delete (i, j) . delete (j, i) $ _mayBreak st })
259+ | otherwise = (ev : ev' : evs') : [ev' : evs'' | evs'' <- insert ev evs']
240−removeErrorEvents :: [Event] -> [Event]
261+ connectionId :: ExpEvent -> Variable ConnectionId
241−removeErrorEvents [] = []
262+ connectionId (ExpConnectionOpened connId) = connId
242−removeErrorEvents (ErrorEvent _ : evs) = removeErrorEvents evs
263+ connectionId (ExpConnectionClosed connId) = connId
243−removeErrorEvents (ev : evs) = ev : removeErrorEvents evs
264+ connectionId (ExpReceived connId _) = connId
245--------------------------------------------------------------------------------
266--------------------------------------------------------------------------------
246-- Script generators --
267-- Script generators --
@@ -472,21 +493,61 @@ testScriptGen transport scriptGen =
472 forAll scriptGen $ \script ->
493 forAll scriptGen $ \script ->
473 morallyDubiousIOProperty $ do
494 morallyDubiousIOProperty $ do
474 logShow script
495 logShow script
475− (evs, vst) <- execScript transport script
496+ mErr <- verify transport script
476− return $ case verify vst script evs of
497+ return $ case mErr of
477− Nothing -> result { ok = Just True
498+ Right () -> result { ok = Just True }
479− Just err -> result { ok = Just False
499+ Left err -> result { ok = Just False
480− , reason = '\n' : err ++ "\nAll events: " ++ show evs
500+ , reason = '\n' : err ++ "\n"
483testScript :: (Transport, TransportInternals) -> Script -> Assertion
503testScript :: (Transport, TransportInternals) -> Script -> Assertion
484testScript transport script = do
504testScript transport script = do
485 logShow script
505 logShow script
486− (evs, vst) <- execScript transport script
506+ mErr <- verify transport script
487− case verify vst script evs of
507+ case mErr of
488− Just err -> assertFailure $ "Failed with script " ++ show script ++ ": " ++ err ++ "\nAll events: " ++ show evs
508+ Left err -> assertFailure $ "Failed with script " ++ show script ++ ": " ++ err ++ "\n"
489− Nothing -> return ()
509+ Right () -> return ()
511+--------------------------------------------------------------------------------
513+--------------------------------------------------------------------------------
515+endPoints :: Accessor RunState [EndPoint]
516+endPoints = accessor _endPoints (\es st -> st { _endPoints = es })
518+endPointAtIx :: EndPointIx -> Accessor RunState EndPoint
519+endPointAtIx i = endPoints >>> listAccessor i
521+connections :: Accessor RunState [(TargetAddress, Connection, Variable ConnectionId)]
522+connections = accessor _connections (\cs st -> st { _connections = cs })
524+connectionAt :: ConnectionIx -> Accessor RunState (TargetAddress, Connection, Variable ConnectionId)
525+connectionAt i = connections >>> listAccessor i
527+expectedEvents :: Accessor RunState (Map EndPointAddress [ExpEvent])
528+expectedEvents = accessor _expectedEvents (\es st -> st { _expectedEvents = es })
530+expectedEventsAt :: EndPointAddress -> Accessor RunState [ExpEvent]
531+expectedEventsAt addr = expectedEvents >>> DAC.mapDefault [] addr
533+forwardingThreads :: Accessor RunState [ThreadId]
534+forwardingThreads = accessor _forwardingThreads (\ts st -> st { _forwardingThreads = ts })
536+--------------------------------------------------------------------------------
537+-- Pretty-printing --
538+--------------------------------------------------------------------------------
540+verticalList :: Show a => [a] -> PP.Doc
541+verticalList = PP.brackets . PP.vcat . map (PP.text . show)
543+instance Show Script where
544+ show = ("\n" ++) . show . verticalList
546+instance Show [Event] where
547+ show = ("\n" ++) . show . verticalList
549+instance Show [ExpEvent] where
550+ show = ("\n" ++) . show . verticalList
491--------------------------------------------------------------------------------
552--------------------------------------------------------------------------------
492-- Draw random values from probability distributions --
553-- Draw random values from probability distributions --
@@ -529,13 +590,6 @@ log = appendFile "log" . (++ "\n")
529logShow :: Show a => a -> IO ()
590logShow :: Show a => a -> IO ()
530logShow = log . show
591logShow = log . show
532−throwIfLeft :: Exception a => IO (Either a b) -> IO b
539instance Arbitrary ByteString where
593instance Arbitrary ByteString where
540 arbitrary = do
594 arbitrary = do
541 len <- chooseFrom' (NormalD { mean = 5, stdDev = 10 }) (0, 100)
595 len <- chooseFrom' (NormalD { mean = 5, stdDev = 10 }) (0, 100)
@@ -548,8 +602,5 @@ listAccessor i = accessor (!! i) (error "listAccessor.set not defined")
548snoc :: a -> [a] -> [a]
602snoc :: a -> [a] -> [a]
549snoc x xs = xs ++ [x]
603snoc x xs = xs ++ [x]
551−destruct :: Map EndPointIx [Event] -> EndPointIx -> Maybe (Event, Map EndPointIx [Event])
605+groupByKey :: Ord a => [(a, b)] -> Map a [b]
552−destruct evs i =
606+groupByKey = Map.fromListWith (++) . map (second return)
555− ev : evs' -> Just (ev, Map.insert i evs' evs)