@@ -24,14 +24,16 @@ import Test.QuickCheck.Property (morallyDubiousIOProperty, Result(..), result)
2424import Test.HUnit (Assertion, assertFailure)
2525import Data.Map (Map)
2626import qualified Data.Map as Map
27+import Control.Category ((>>>))
2728import Control.Applicative ((<$>))
2829import Control.Exception (Exception, throwIO)
2930import Control.Concurrent (forkIO, threadDelay)
3031import Control.Concurrent.Chan (Chan, newChan, writeChan, readChan)
3132import Control.Monad (replicateM, void)
32−import Data.List (inits)
33+import Data.List (inits, delete)
3334import Data.ByteString (ByteString)
3435import Data.ByteString.Char8 (pack)
36+import Data.Accessor (Accessor, accessor, (^:), (^.), (^=))
3537import qualified Data.ByteString as BSS (concat)
3638import qualified Text.PrettyPrint as PP
3739
@@ -48,6 +50,11 @@ import Network.Transport.TCP.Mock.Socket (scheduleReadAction, sClose)
4850-- Script infrastructure --
4951--------------------------------------------------------------------------------
5052
53+type EndPointIx = Int
54+type SourceEndPointIx = Int
55+type TargetEndPointIx = Int
56+type ConnectionIx = Int
57+
5158-- | We randomly generate /scripts/ which are essentially a deep embedding of
5259-- the Transport API. These scripts are then executed and the results compared
5360-- against an abstract interpreter.
@@ -57,20 +64,20 @@ data ScriptCmd =
5764 -- | @Connect i j@ creates a connection from endpoint @i@ to endpoint @j@,
5865 -- where @i@ and @j@ are indices and refer to the @i@th and @j@th endpoint
5966 -- created by NewEndPoint
60− | Connect Int Int
67+ | Connect SourceEndPointIx TargetEndPointIx
6168 -- | @Close i@ closes the @i@ connection created using 'Connect'. Note that
6269 -- closing a connection does not shift other indices; in other words, in
6370 -- @[Connect 0 0, Close 0, Connect 0 0, Close 0]@ the second 'Close'
6471 -- refers to the first (already closed) connection
65− | Close Int
72+ | Close ConnectionIx
6673 -- | @Send i bs@ sends payload @bs@ on the @i@ connection created
67− | Send Int [ByteString]
74+ | Send ConnectionIx [ByteString]
6875 -- | @BreakAfterReads n i j@ force-closes the socket between endpoints @i@
6976 -- and @j@ after @n@ reads by @i@
7077 --
7178 -- We should have @i /= j@ because the TCP transport does not use sockets
7279 -- for connections from an endpoint to itself
73− | BreakAfterReads Int Int Int
80+ | BreakAfterReads Int SourceEndPointIx TargetEndPointIx
7481 deriving Show
7582
7683type Script = [ScriptCmd]
@@ -90,34 +97,40 @@ instance Show Script where
9097
9198instance Show (Map Int [Event]) where
9299 show = ("\n" ++) . show . eventsDoc
93−
100+
101+--------------------------------------------------------------------------------
102+-- Execution --
103+--------------------------------------------------------------------------------
104+
94105-- | Execute a script
95106--
96107-- Execute ignores error codes reported back. Instead, we verify the events
97108-- that are posted
98−execScript :: (Transport, TransportInternals) -> Script -> IO (Map Int [Event])
109+execScript :: (Transport, TransportInternals) -> Script -> IO (Map EndPointIx [Event], VerificationState)
99110execScript (transport, transportInternals) script = do
100111 chan <- newChan
101− runScript chan script
102− collectAll chan
112+ vst <- runScript chan script
113+ evs <- collectAll chan
114+ return (evs, vst)
103115 where
104− runScript :: Chan (Maybe (Int, Event)) -> Script -> IO ()
116+ runScript :: Chan (Maybe (EndPointIx, Event)) -> Script -> IO VerificationState
105117 runScript chan = go [] []
106118 where
107− go :: [EndPoint] -> [Either (TransportError ConnectErrorCode) Connection] -> Script -> IO ()
108− go _endPoints _conns [] = do
119+ go :: [EndPoint] -> [Either (TransportError ConnectErrorCode) Connection] -> Script -> IO VerificationState
120+ go endPoints _conns [] = do
109121 threadDelay 10000
110122 writeChan chan Nothing
123+ return (initialVerificationState (map address endPoints))
111124 go endPoints conns (NewEndPoint : cmds) = do
112125 endPoint <- throwIfLeft $ newEndPoint transport
113126 let endPointIx = length endPoints
114127 _tid <- forkIO $ forwardTo chan (endPointIx, endPoint)
115128 threadDelay 10000
116− go (endPoints ++ [endPoint]) conns cmds
129+ go (endPoint `snoc` endPoints) conns cmds
117130 go endPoints conns (Connect fr to : cmds) = do
118131 conn <- connect (endPoints !! fr) (address (endPoints !! to)) ReliableOrdered defaultConnectHints
119132 threadDelay 10000
120− go endPoints (conns ++ [conn]) cmds
133+ go endPoints (conn `snoc` conns) cmds
121134 go endPoints conns (Close connIx : cmds) = do
122135 case conns !! connIx of
123136 Left _err -> return ()
@@ -135,7 +148,7 @@ execScript (transport, transportInternals) script = do
135148 scheduleReadAction sock n (putStrLn "Closing" >> sClose sock)
136149 go endPoints conns cmds
137150
138− forwardTo :: Chan (Maybe (Int, Event)) -> (Int, EndPoint) -> IO ()
151+ forwardTo :: Chan (Maybe (EndPointIx, Event)) -> (EndPointIx, EndPoint) -> IO ()
139152 forwardTo chan (ix, endPoint) = go
140153 where
141154 go :: IO ()
@@ -145,7 +158,7 @@ execScript (transport, transportInternals) script = do
145158 EndPointClosed -> return ()
146159 _ -> writeChan chan (Just (ix, ev)) >> go
147160
148− collectAll :: Chan (Maybe (Int, Event)) -> IO (Map Int [Event])
161+ collectAll :: Chan (Maybe (EndPointIx, Event)) -> IO (Map EndPointIx [Event])
149162 collectAll chan = go Map.empty
150163 where
151164 go :: Map Int [Event] -> IO (Map Int [Event])
@@ -159,41 +172,75 @@ execScript (transport, transportInternals) script = do
159172 insertEvent ev Nothing = Just [ev]
160173 insertEvent ev (Just evs) = Just (ev : evs)
161174
162−verify :: Script -> Map Int [Event] -> Maybe String
163−verify = go []
164− where
165− go :: [(Int, ConnectionId)] -> Script -> Map Int [Event] -> Maybe String
166− go _conns [] evs =
167− if concat (Map.elems evs) == []
168− then Nothing
169− else Just $ "Unexpected events: " ++ show evs
170− go conns (NewEndPoint : cmds) evs =
171− go conns cmds evs
172− go conns (Connect _fr to : cmds) evs =
173− let epEvs = evs Map.! to
174− in case epEvs of
175− (ConnectionOpened connId _rel _addr : epEvs') ->
176− go (conns ++ [(to, connId)]) cmds (Map.insert to epEvs' evs)
177− _ ->
178− Just $ "Missing (ConnectionOpened <<connId>> <<rel>> <<addr>>) event in " ++ show evs
179− go conns (Close connIx : cmds) evs =
180− let (epIx, connId) = conns !! connIx
181− epEvs = evs Map.! epIx
182− in case epEvs of
183− (ConnectionClosed connId' : epEvs') | connId' == connId ->
184− go conns cmds (Map.insert epIx epEvs' evs)
185− _ ->
186− Just $ "Missing (ConnectionClosed " ++ show connId ++ ") event in " ++ show evs
187− go conns (Send connIx payload : cmds) evs =
188− let (epIx, connId) = conns !! connIx
189− epEvs = evs Map.! epIx
190− in case epEvs of
191− (Received connId' payload' : epEvs') | connId' == connId && BSS.concat payload == BSS.concat payload' ->
192− go conns cmds (Map.insert epIx epEvs' evs)
193− _ ->
194− Just $ "Missing (Received " ++ show connId ++ " " ++ show payload ++ ") event in " ++ show epEvs
195− go conns (BreakAfterReads n i j : cmds) evs =
196− go conns cmds evs
175+--------------------------------------------------------------------------------
176+-- Verification --
177+--------------------------------------------------------------------------------
178+
179+data VerificationState = VerificationState {
180+ endPointAddrs :: [EndPointAddress]
181+ , _connections :: [(SourceEndPointIx, TargetEndPointIx, ConnectionId)]
182+ , _mayBreak :: [(SourceEndPointIx, TargetEndPointIx)]
183+ }
184+
185+initialVerificationState :: [EndPointAddress] -> VerificationState
186+initialVerificationState addrs = VerificationState {
187+ endPointAddrs = addrs
188+ , _connections = []
189+ , _mayBreak = []
190+ }
191+
192+-- TODO: we currently have no way to verify addresses in ConnectionOpened
193+-- or EventConnectionLost (because we don't know the addresses of the endpoints)
194+verify :: VerificationState -> Script -> Map EndPointIx [Event] -> Maybe String
195+verify _st [] evs =
196+ -- TODO: we should compare the error events against mayBreak, but we
197+ -- cannot because we don't know the endpoint addresses
198+ if removeErrorEvents (concat (Map.elems evs)) == []
199+ then Nothing
200+ else Just $ "Unexpected events: " ++ show evs
201+verify st (NewEndPoint : cmds) evs =
202+ verify st cmds evs
203+verify st (Connect fr to : cmds) evs =
204+ case destruct evs to of
205+ Just (ConnectionOpened connId _rel _addr, evs') ->
206+ verify (connections ^: snoc (fr, to, connId) $ st) cmds evs'
207+ ev ->
208+ Just $ "Missing (ConnectionOpened <<connId>> <<rel>> <<addr>>). Got " ++ show ev
209+verify st (Close connIx : cmds) evs =
210+ let (_fr, to, connId) = st ^. connectionAt connIx in
211+ case destruct evs to of
212+ Just (ConnectionClosed connId', evs') | connId' == connId ->
213+ verify st cmds evs'
214+ ev ->
215+ Just $ "Missing (ConnectionClosed " ++ show connId ++ "). Got " ++ show ev
216+verify st (Send connIx payload : cmds) evs =
217+ let (fr, to, connId) = st ^. connectionAt connIx in
218+ case destruct evs to of
219+ Just (Received connId' payload', evs') | connId' == connId && BSS.concat payload == BSS.concat payload' ->
220+ verify st cmds evs'
221+ Just (ErrorEvent (TransportError (EventConnectionLost _addr) _), evs') | st ^. mayBreak fr to ->
222+ verify st cmds evs'
223+ ev ->
224+ Just $ "Missing (Received " ++ show connId ++ " " ++ show payload ++ "). Got " ++ show ev
225+verify st (BreakAfterReads _n i j : cmds) evs =
226+ verify (mayBreak i j ^= True $ st) cmds evs
227+
228+connections :: Accessor VerificationState [(SourceEndPointIx, TargetEndPointIx, ConnectionId)]
229+connections = accessor _connections (\cs st -> st { _connections = cs })
230+
231+connectionAt :: ConnectionIx -> Accessor VerificationState (SourceEndPointIx, TargetEndPointIx, ConnectionId)
232+connectionAt i = connections >>> listAccessor i
233+
234+mayBreak :: EndPointIx -> EndPointIx -> Accessor VerificationState Bool
235+mayBreak i j = accessor
236+ (\st -> (i, j) `elem` _mayBreak st || (j, i) `elem` _mayBreak st)
237+ (\b st -> if b then st { _mayBreak = (i, j) : _mayBreak st }
238+ else st { _mayBreak = delete (i, j) . delete (j, i) $ _mayBreak st })
239+
240+removeErrorEvents :: [Event] -> [Event]
241+removeErrorEvents [] = []
242+removeErrorEvents (ErrorEvent _ : evs) = removeErrorEvents evs
243+removeErrorEvents (ev : evs) = ev : removeErrorEvents evs
197244
198245--------------------------------------------------------------------------------
199246-- Script generators --
@@ -425,8 +472,8 @@ testScriptGen transport scriptGen =
425472 forAll scriptGen $ \script ->
426473 morallyDubiousIOProperty $ do
427474 logShow script
428− evs <- execScript transport script
429− return $ case verify script evs of
475+ (evs, vst) <- execScript transport script
476+ return $ case verify vst script evs of
430477 Nothing -> result { ok = Just True
431478 }
432479 Just err -> result { ok = Just False
@@ -436,34 +483,11 @@ testScriptGen transport scriptGen =
436483testScript :: (Transport, TransportInternals) -> Script -> Assertion
437484testScript transport script = do
438485 logShow script
439− evs <- execScript transport script
440− case verify script evs of
441− Just err -> assertFailure $ "Failed with script " ++ show script ++ ": " ++ err
486+ (evs, vst) <- execScript transport script
487+ case verify vst script evs of
488+ Just err -> assertFailure $ "Failed with script " ++ show script ++ ": " ++ err ++ "\nAll events: " ++ show evs
442489 Nothing -> return ()
443490
444−--------------------------------------------------------------------------------
445−-- Auxiliary
446−--------------------------------------------------------------------------------
447−
448−log :: String -> IO ()
449−log = appendFile "log" . (++ "\n")
450−
451−logShow :: Show a => a -> IO ()
452−logShow = log . show
453−
454−throwIfLeft :: Exception a => IO (Either a b) -> IO b
455−throwIfLeft p = do
456− mb <- p
457− case mb of
458− Left a -> throwIO a
459− Right b -> return b
460−
461−instance Arbitrary ByteString where
462− arbitrary = do
463− len <- chooseFrom' (NormalD { mean = 5, stdDev = 10 }) (0, 100)
464− xs <- replicateM len arbitrary
465− return (pack xs)
466−
467491--------------------------------------------------------------------------------
468492-- Draw random values from probability distributions --
469493--------------------------------------------------------------------------------
@@ -494,3 +518,38 @@ chooseFrom d (lo, hi) = findCandidate
494518chooseFrom' :: Distribution d => d -> (Int, Int) -> Gen Int
495519chooseFrom' d (lo, hi) =
496520 round <$> chooseFrom d (fromIntegral lo, fromIntegral hi)
521+
522+--------------------------------------------------------------------------------
523+-- Auxiliary
524+--------------------------------------------------------------------------------
525+
526+log :: String -> IO ()
527+log = appendFile "log" . (++ "\n")
528+
529+logShow :: Show a => a -> IO ()
530+logShow = log . show
531+
532+throwIfLeft :: Exception a => IO (Either a b) -> IO b
533+throwIfLeft p = do
534+ mb <- p
535+ case mb of
536+ Left a -> throwIO a
537+ Right b -> return b
538+
539+instance Arbitrary ByteString where
540+ arbitrary = do
541+ len <- chooseFrom' (NormalD { mean = 5, stdDev = 10 }) (0, 100)
542+ xs <- replicateM len arbitrary
543+ return (pack xs)
544+
545+listAccessor :: Int -> Accessor [a] a
546+listAccessor i = accessor (!! i) (error "listAccessor.set not defined")
547+
548+snoc :: a -> [a] -> [a]
549+snoc x xs = xs ++ [x]
550+
551+destruct :: Map EndPointIx [Event] -> EndPointIx -> Maybe (Event, Map EndPointIx [Event])
552+destruct evs i =
553+ case evs Map.! i of
554+ [] -> Nothing
555+ ev : evs' -> Just (ev, Map.insert i evs' evs)