-- Test the TCP transport using QuickCheck generated scripts -- -- TODO: This is not quite working yet. The main problem, I think, is the -- allocation of "bundle ID"s to connections. The problem is exposed by the -- aptly-named regression test script_Foo (to be renamed once I figure out what -- bug that test is actually exposing :) module Main ( main -- Shush the compiler about unused definitions , log , logShow , forAllShrink , inits , expectedFailure ) where import Prelude hiding (log) import Test.Framework (Test, TestName, defaultMain, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.Framework.Providers.HUnit (testCase) import Test.QuickCheck ( Gen , choose , suchThatMaybe , forAll , forAllShrink , Property , Arbitrary(arbitrary) ) import Test.QuickCheck.Property (morallyDubiousIOProperty, Result(..), result) import Test.HUnit (Assertion, assertFailure) import Data.Map (Map) import qualified Data.Map as Map import Control.Category ((>>>)) import Control.Applicative ((<$>)) import Control.Exception (Exception, throwIO, try) import Control.Concurrent (forkIO, threadDelay, ThreadId, killThread) import Control.Monad (MonadPlus(..), replicateM, forever, guard) import Control.Monad.State (StateT, execStateT) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Typeable (Typeable) import Data.Maybe (isJust) import Data.List (inits) import Data.ByteString (ByteString) import Data.ByteString.Char8 (pack) import Data.Accessor (Accessor, accessor, (^.)) import Data.Accessor.Monad.Trans.State (get, set, modify) import qualified Data.Accessor.Container as DAC (set, mapDefault) import qualified Data.ByteString as BSS (concat) import qualified Text.PrettyPrint as PP import Data.Unique (Unique, newUnique, hashUnique) import Data.Concurrent.Queue.MichaelScott (newQ, pushL, tryPopR) import Data.Set (Set) import qualified Data.Set as Set import GHC.Stack (currentCallStack, renderStack) import Network.Transport import Network.Transport.TCP ( createTransportExposeInternals , defaultTCPParameters , TransportInternals(socketBetween) ) import Network.Transport.TCP.Mock.Socket (Socket, scheduleReadAction, sClose) -------------------------------------------------------------------------------- -- Script infrastructure -- -------------------------------------------------------------------------------- type EndPointIx = Int type SourceEndPointIx = Int type TargetEndPointIx = Int type ConnectionIx = Int -- | We randomly generate /scripts/ which are essentially a deep embedding of -- the Transport API. These scripts are then executed and the results compared -- against an abstract interpreter. data ScriptCmd = -- | Create a new endpoint NewEndPoint -- | @Connect i j@ creates a connection from endpoint @i@ to endpoint @j@, -- where @i@ and @j@ are indices and refer to the @i@th and @j@th endpoint -- created by NewEndPoint | Connect SourceEndPointIx TargetEndPointIx -- | @Close i@ closes the @i@ connection created using 'Connect'. Note that -- closing a connection does not shift other indices; in other words, in -- @[Connect 0 0, Close 0, Connect 0 0, Close 0]@ the second 'Close' -- refers to the first (already closed) connection | Close ConnectionIx -- | @Send i bs@ sends payload @bs@ on the @i@ connection created | Send ConnectionIx [ByteString] -- | @BreakAfterReads n i j@ force-closes the socket between endpoints @i@ -- and @j@ after @n@ reads by @i@ -- -- We should have @i /= j@ because the TCP transport does not use sockets -- for connections from an endpoint to itself | BreakAfterReads Int SourceEndPointIx TargetEndPointIx deriving Show type Script = [ScriptCmd] -------------------------------------------------------------------------------- -- Execute and verify scripts -- -------------------------------------------------------------------------------- data Variable a = Value a | Variable Unique deriving Eq instance Show a => Show (Variable a) where show (Value x) = show x show (Variable u) = "<<" ++ show (hashUnique u) ++ ">>" -- | In the implementation "bundles" are purely a conceptual idea, but in the -- verifier we need to concretize this notion type BundleId = Int data ConnectionInfo = ConnectionInfo { source :: EndPointAddress , target :: EndPointAddress , connectionId :: Variable ConnectionId , connectionBundle :: BundleId } deriving Show data ExpEvent = ExpConnectionOpened ConnectionInfo | ExpConnectionClosed ConnectionInfo | ExpReceived ConnectionInfo [ByteString] | ExpConnectionLost BundleId EndPointAddress deriving Show data RunState = RunState { _endPoints :: [EndPoint] , _connections :: [(Connection, ConnectionInfo)] , _expectedEvents :: Map EndPointAddress [ExpEvent] -- | For each endpoint we create we create a thread that forwards the events -- of that endpoint to a central channel. We collect the thread IDs so that -- we can kill these thread when we are done. , _forwardingThreads :: [ThreadId] -- | When a connection from A to be may break, we add both (A, B, n) -- and (B, A, n) to _mayBreak. Then once we detect that from A to B -- has in fact broken we move (A, B, n), *and/or* (B, A, n), from _mayBreak -- to _broken. Note that we can detect that a connection has been broken -- in one direction even if we haven't yet detected that the connection -- has broken in the other direction. -- -- | Invariant: not mayBreak && broken , _mayBreak :: Set (EndPointAddress, EndPointAddress, BundleId) , _broken :: Set (EndPointAddress, EndPointAddress, BundleId) -- | Current bundle ID between two endpoints -- -- Invariant: For all keys (A, B), A <= B , _currentBundle :: Map (EndPointAddress, EndPointAddress) BundleId } initialRunState :: RunState initialRunState = RunState { _endPoints = [] , _connections = [] , _expectedEvents = Map.empty , _forwardingThreads = [] , _mayBreak = Set.empty , _broken = Set.empty , _currentBundle = Map.empty } verify :: (Transport, TransportInternals) -> Script -> IO (Either String ()) verify (transport, transportInternals) script = do allEvents <- newQ let runScript :: Script -> StateT RunState IO () runScript = mapM_ runCmd runCmd :: ScriptCmd -> StateT RunState IO () runCmd NewEndPoint = do mEndPoint <- liftIO $ newEndPoint transport case mEndPoint of Right endPoint -> do tid <- liftIO $ forkIO (forward endPoint) append endPoints endPoint append forwardingThreads tid set (expectedEventsAt (address endPoint)) [] Left err -> liftIO $ throwIO err runCmd (Connect i j) = do endPointA <- get (endPointAtIx i) endPointB <- address <$> get (endPointAtIx j) mConn <- liftIO $ connect endPointA endPointB ReliableOrdered defaultConnectHints let bundleId = currentBundle (address endPointA) endPointB connBroken = broken (address endPointA) endPointB connMayBreak = mayBreak (address endPointA) endPointB case mConn of Right conn -> do bundleBroken <- get bundleId >>= get . connBroken currentBundleId <- if bundleBroken then modify bundleId (+ 1) >> get bundleId else get bundleId connId <- Variable <$> liftIO newUnique let connInfo = ConnectionInfo { source = address endPointA , target = endPointB , connectionId = connId , connectionBundle = currentBundleId } append connections (conn, connInfo) append (expectedEventsAt endPointB) (ExpConnectionOpened connInfo) Left err -> do currentBundleId <- get bundleId expectingBreak <- get $ connMayBreak currentBundleId if expectingBreak then do set (connMayBreak currentBundleId) False set (connBroken currentBundleId) True else liftIO $ throwIO err runCmd (Close i) = do (conn, connInfo) <- get (connectionAt i) liftIO $ close conn append (expectedEventsAt (target connInfo)) (ExpConnectionClosed connInfo) runCmd (Send i payload) = do (conn, connInfo) <- get (connectionAt i) mResult <- liftIO $ send conn payload let connMayBreak = mayBreak (source connInfo) (target connInfo) (connectionBundle connInfo) connBroken = broken (source connInfo) (target connInfo) (connectionBundle connInfo) case mResult of Right () -> return () Left err -> do expectingBreak <- get connMayBreak isBroken <- get connBroken if expectingBreak || isBroken then do set connMayBreak False set connBroken True else liftIO $ throwIO err append (expectedEventsAt (target connInfo)) (ExpReceived connInfo payload) -- TODO: This will only work if a connection between 'i' and 'j' has -- already been established. We would need to modify the mock network -- layer to support breaking "future" connections runCmd (BreakAfterReads n i j) = do endPointA <- address <$> get (endPointAtIx i) endPointB <- address <$> get (endPointAtIx j) liftIO $ do sock <- socketBetween transportInternals endPointA endPointB scheduleReadAction sock n $ breakSocket sock currentBundleId <- get (currentBundle endPointA endPointB) set (mayBreak endPointA endPointB currentBundleId) True set (mayBreak endPointB endPointA currentBundleId) True append (expectedEventsAt endPointA) (ExpConnectionLost currentBundleId endPointB) append (expectedEventsAt endPointB) (ExpConnectionLost currentBundleId endPointA) forward :: EndPoint -> IO () forward endPoint = forever $ do ev <- receive endPoint pushL allEvents (address endPoint, ev) collectEvents :: RunState -> IO (Map EndPointAddress [Event]) collectEvents st = do threadDelay 10000 mapM_ killThread (st ^. forwardingThreads) evs <- go [] return $ groupByKey (map address (st ^. endPoints)) evs where go acc = do mEv <- tryPopR allEvents case mEv of Just ev -> go (ev : acc) Nothing -> return (reverse acc) st <- execStateT (runScript script) initialRunState actualEvents <- collectEvents st let eventsMatch = all (uncurry match) $ zip (Map.elems (st ^. expectedEvents)) (Map.elems actualEvents) return $ if eventsMatch then Right () else Left ("Could not match " ++ show (st ^. expectedEvents) ++ " and " ++ show actualEvents) breakSocket :: Socket -> IO () breakSocket sock = do currentCallStack >>= putStrLn . renderStack sClose sock -------------------------------------------------------------------------------- -- Match expected and actual events -- -------------------------------------------------------------------------------- -- | Match a list of expected events to a list of actual events, taking into -- account that events may be reordered match :: [ExpEvent] -> [Event] -> Bool match expected actual = any (`canUnify` actual) (possibleTraces expected) possibleTraces :: [ExpEvent] -> [[ExpEvent]] possibleTraces = go where go [] = [[]] go (ev@(ExpConnectionLost _ _) : evs) = [ trace | evs' <- possibleTraces evs, trace <- insertConnectionLost ev evs' ] go (ev : evs) = [ trace | evs' <- possibleTraces evs, trace <- insertEvent ev evs' ] -- We don't know when exactly the error will occur (indeed, it may never -- happen at all), but it must occur before any future connection lost -- event to the same destination. -- If it occurs now, then all other events on this bundle will not happen. insertConnectionLost :: ExpEvent -> [ExpEvent] -> [[ExpEvent]] insertConnectionLost ev [] = [[ev], []] insertConnectionLost ev@(ExpConnectionLost bid addr) (ev' : evs) = (ev : removeBundle bid (ev' : evs)) : case ev' of ExpConnectionLost _ addr' | addr == addr' -> [] _ -> [ev' : evs' | evs' <- insertConnectionLost ev evs] insertConnectionLost _ _ = error "The impossible happened" -- All other events can be arbitrarily reordered /across/ connections, but -- never /within/ connections insertEvent :: ExpEvent -> [ExpEvent] -> [[ExpEvent]] insertEvent ev [] = [[ev]] insertEvent ev (ev' : evs) = (ev : ev' : evs) : if eventConnId ev == eventConnId ev' then [] else [ev' : evs' | evs' <- insertEvent ev evs] removeBundle :: BundleId -> [ExpEvent] -> [ExpEvent] removeBundle bid = filter ((/= bid) . eventBundleId) eventBundleId :: ExpEvent -> BundleId eventBundleId (ExpConnectionOpened connInfo) = connectionBundle connInfo eventBundleId (ExpConnectionClosed connInfo) = connectionBundle connInfo eventBundleId (ExpReceived connInfo _) = connectionBundle connInfo eventBundleId (ExpConnectionLost bid _) = bid eventConnId :: ExpEvent -> Maybe (Variable ConnectionId) eventConnId (ExpConnectionOpened connInfo) = Just $ connectionId connInfo eventConnId (ExpConnectionClosed connInfo) = Just $ connectionId connInfo eventConnId (ExpReceived connInfo _) = Just $ connectionId connInfo eventConnId (ExpConnectionLost _ _) = Nothing -------------------------------------------------------------------------------- -- Unification -- -------------------------------------------------------------------------------- type Substitution = Map Unique ConnectionId newtype Unifier a = Unifier { runUnifier :: Substitution -> Maybe (a, Substitution) } instance Monad Unifier where return x = Unifier $ \subst -> Just (x, subst) x >>= f = Unifier $ \subst -> case runUnifier x subst of Nothing -> Nothing Just (a, subst') -> runUnifier (f a) subst' fail _str = mzero instance MonadPlus Unifier where mzero = Unifier $ const Nothing f `mplus` g = Unifier $ \subst -> case runUnifier f subst of Nothing -> runUnifier g subst Just (a, subst') -> Just (a, subst') class Unify a b where unify :: a -> b -> Unifier () canUnify :: Unify a b => a -> b -> Bool canUnify a b = isJust $ runUnifier (unify a b) Map.empty instance Unify Unique ConnectionId where unify x cid = Unifier $ \subst -> case Map.lookup x subst of Just cid' -> if cid == cid' then Just ((), subst) else Nothing Nothing -> Just ((), Map.insert x cid subst) instance Unify (Variable ConnectionId) ConnectionId where unify (Variable x) connId = unify x connId unify (Value connId') connId = guard $ connId' == connId instance Unify ExpEvent Event where unify (ExpConnectionOpened connInfo) (ConnectionOpened connId _ _) = unify (connectionId connInfo) connId unify (ExpConnectionClosed connInfo) (ConnectionClosed connId) = unify (connectionId connInfo) connId unify (ExpReceived connInfo payload) (Received connId payload') = do guard $ BSS.concat payload == BSS.concat payload' unify (connectionId connInfo) connId unify (ExpConnectionLost _ addr) (ErrorEvent (TransportError (EventConnectionLost addr') _)) = guard $ addr == addr' unify _ _ = fail "Cannot unify" instance Unify a b => Unify [a] [b] where unify [] [] = return () unify (x:xs) (y:ys) = unify x y >> unify xs ys unify _ _ = fail "Cannot unify" -------------------------------------------------------------------------------- -- Script generators -- -------------------------------------------------------------------------------- script_NewEndPoint :: Int -> Gen Script script_NewEndPoint numEndPoints = return (replicate numEndPoints NewEndPoint) script_Connect :: Int -> Gen Script script_Connect numEndPoints = do script <- go return (replicate numEndPoints NewEndPoint ++ script) where go :: Gen Script go = do next <- choose (0, 1) :: Gen Int case next of 0 -> do fr <- choose (0, numEndPoints - 1) to <- choose (0, numEndPoints - 1) cmds <- go return (Connect fr to : cmds) _ -> return [] script_ConnectClose :: Int -> Gen Script script_ConnectClose numEndPoints = do script <- go Map.empty return (replicate numEndPoints NewEndPoint ++ script) where go :: Map Int Bool -> Gen Script go conns = do next <- choose (0, 2) :: Gen Int case next of 0 -> do fr <- choose (0, numEndPoints - 1) to <- choose (0, numEndPoints - 1) cmds <- go (Map.insert (Map.size conns) True conns) return (Connect fr to : cmds) 1 -> do mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns case mConn of Nothing -> go conns Just conn -> do cmds <- go (Map.insert conn False conns) return (Close conn : cmds) _ -> return [] isOpen :: Map Int Bool -> Int -> Bool isOpen conns connIx = connIx `Map.member` conns && conns Map.! connIx script_ConnectSendClose :: Int -> Gen Script script_ConnectSendClose numEndPoints = do script <- go Map.empty return (replicate numEndPoints NewEndPoint ++ script) where go :: Map Int Bool -> Gen Script go conns = do next <- choose (0, 3) :: Gen Int case next of 0 -> do fr <- choose (0, numEndPoints - 1) to <- choose (0, numEndPoints - 1) cmds <- go (Map.insert (Map.size conns) True conns) return (Connect fr to : cmds) 1 -> do mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns case mConn of Nothing -> go conns Just conn -> do numSegments <- choose (0, 2) payload <- replicateM numSegments arbitrary cmds <- go conns return (Send conn payload : cmds) 2 -> do mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns case mConn of Nothing -> go conns Just conn -> do cmds <- go (Map.insert conn False conns) return (Close conn : cmds) _ -> return [] isOpen :: Map Int Bool -> Int -> Bool isOpen conns connIx = connIx `Map.member` conns && conns Map.! connIx withErrors :: Int -> Gen Script -> Gen Script withErrors numErrors gen = gen >>= insertError numErrors where insertError :: Int -> Script -> Gen Script insertError _ [] = return [] insertError n (Connect i j : cmds) | i /= j = do insert <- arbitrary if insert && n > 0 then do numReads <- chooseFrom' NormalD { mean = 5, stdDev = 10 } (0, 100) swap <- arbitrary if swap then return $ Connect i j : BreakAfterReads numReads j i : cmds else return $ Connect i j : BreakAfterReads numReads i j : cmds else do cmds' <- insertError (n - 1) cmds return $ Connect i j : cmds' insertError n (cmd : cmds) = do cmds' <- insertError n cmds return $ cmd : cmds' -------------------------------------------------------------------------------- -- Individual scripts to test specific bugs -- -------------------------------------------------------------------------------- -- | Bug #1 -- -- When process A wants to close the heavyweight connection to process B it -- sends a CloseSocket request together with the ID of the last connection from -- B. When B receives the CloseSocket request it can compare this ID to the last -- connection it created; if they don't match, B knows that there are some -- messages still on the way from B to A (in particular, a CreatedConnection -- message) which will cancel the CloseSocket request from A. Hence, it will -- know to ignore the CloseSocket request from A. -- -- The bug was that we recorded the last _created_ outgoing connection on the -- local endpoint, but the last _received_ incoming connection on the state of -- the heavyweight connection. So, in the script below, the following happened: -- -- A connects to B, records "last connection ID is 1024" -- A closes the lightweight connection, sends [CloseConnection 1024] -- A closes the heivyweight connection, sends [CloseSocket 0] -- -- (the 0 here indicates that it had not yet received any connections from B) -- -- B receives the [CloseSocket 0], compares it to the recorded outgoing ID (0), -- confirms that they are equal, and confirms the CloseSocket request. -- -- B connects to A, records "last connection ID is 1024" -- B closes the lightweight connection, sends [CloseConnection 1024] -- B closes the heavyweight connection, sends [CloseSocket 0] -- -- (the 0 here indicates that it has not yet received any connections from A, -- ON THIS HEAVYWEIGHT connection) -- -- A receives the [CloseSocket 0] request, compares it to the last recorded -- outgoing ID (1024), sees that they are not equal, and concludes that this -- must mean that there is still a CreatedConnection message on the way from A -- to B. -- -- This of course is not the case, so B will wait forever for A to confirm -- the CloseSocket request, and deadlock arises. (This deadlock doesn't become -- obvious though until the next attempt from B to connect to A.) -- -- The solution is of course that both the recorded outgoing and recorded -- incoming connection ID must be per heavyweight connection. script_Bug1 :: Script script_Bug1 = [ NewEndPoint , NewEndPoint , Connect 0 1 , Close 0 , Connect 1 0 , Close 1 , Connect 1 0 ] -- | Test ordering of sends script_MultipleSends :: Script script_MultipleSends = [ NewEndPoint , Connect 0 0 , Send 0 ["A"] , Send 0 ["B"] , Send 0 ["C"] , Send 0 ["D"] , Send 0 ["E"] ] -- | Simulate broken network connection during send script_BreakSend :: Script script_BreakSend = [ NewEndPoint , NewEndPoint , Connect 0 1 , BreakAfterReads 1 1 0 , Send 0 ["ping"] ] -- | Simulate broken network connection during connect script_BreakConnect1 :: Script script_BreakConnect1 = [ NewEndPoint , NewEndPoint , Connect 0 1 , BreakAfterReads 1 1 0 , Connect 0 1 ] -- | Simulate broken network connection during connect script_BreakConnect2 :: Script script_BreakConnect2 = [ NewEndPoint , NewEndPoint , Connect 0 1 , BreakAfterReads 1 0 1 , Connect 0 1 ] -- | Simulate broken send, then reconnect script_BreakSendReconnect :: Script script_BreakSendReconnect = [ NewEndPoint , NewEndPoint , Connect 0 1 , BreakAfterReads 1 1 0 , Send 0 ["ping1"] , Connect 0 1 , Send 1 ["ping2"] ] script_Foo :: Script script_Foo = [ NewEndPoint , NewEndPoint , Connect 1 0 , BreakAfterReads 2 0 1 , Send 0 ["pingpong"] , Connect 0 1 ] -------------------------------------------------------------------------------- -- Main application driver -- -------------------------------------------------------------------------------- basicTests :: (Transport, TransportInternals) -> Int -> (Gen Script -> Gen Script) -> [Test] basicTests transport numEndPoints trans = [ testGen "NewEndPoint" transport (trans (script_NewEndPoint numEndPoints)) , testGen "Connect" transport (trans (script_Connect numEndPoints)) , testGen "ConnectClose" transport (trans (script_ConnectClose numEndPoints)) , testGen "ConnectSendClose" transport (trans (script_ConnectSendClose numEndPoints)) ] tests :: (Transport, TransportInternals) -> [Test] tests transport = [ testGroup "Regression tests" [ testOne "Bug1" transport script_Bug1 ] , testGroup "Specific scripts" [ testOne "BreakMultipleSends" transport script_MultipleSends , testOne "BreakSend" transport script_BreakSend , testOne "BreakConnect1" transport script_BreakConnect1 , testOne "BreakConnect2" transport script_BreakConnect2 , testOne "BreakSendReconnect" transport script_BreakSendReconnect , testOne "Foo" transport script_Foo ] , testGroup "Without errors" [ testGroup "One endpoint, with delays" (basicTests transport 1 id) , testGroup "Two endpoints, with delays" (basicTests transport 2 id) , testGroup "Three endpoints, with delays" (basicTests transport 3 id) ] , testGroup "Single error" [ testGroup "Two endpoints, with delays" (basicTests transport 2 (withErrors 1)) , testGroup "Three endpoints, with delays" (basicTests transport 3 (withErrors 1)) ] ] where testOne :: TestName -> (Transport, TransportInternals) -> Script -> Test testOne label transport script = testCase label (testScript transport script) testGen :: TestName -> (Transport, TransportInternals) -> Gen Script -> Test testGen label transport script = testProperty label (testScriptGen transport script) main :: IO () main = do Right transport <- createTransportExposeInternals "127.0.0.1" "8080" defaultTCPParameters defaultMain (tests transport) -------------------------------------------------------------------------------- -- Test infrastructure -- -------------------------------------------------------------------------------- testScriptGen :: (Transport, TransportInternals) -> Gen Script -> Property testScriptGen transport scriptGen = forAll scriptGen $ \script -> morallyDubiousIOProperty $ do logShow script mErr <- try $ verify transport script return $ case mErr of Left (ExpectedFailure str) -> result { ok = Nothing , reason = str } Right (Left err) -> result { ok = Just False , reason = '\n' : err ++ "\n" } Right (Right ()) -> result { ok = Just True } testScript :: (Transport, TransportInternals) -> Script -> Assertion testScript transport script = do logShow script mErr <- try $ verify transport script case mErr of Left (ExpectedFailure _str) -> return () Right (Left err) -> assertFailure $ "Failed with script " ++ show script ++ ": " ++ err ++ "\n" Right (Right ()) -> return () -------------------------------------------------------------------------------- -- Accessors -- -------------------------------------------------------------------------------- endPoints :: Accessor RunState [EndPoint] endPoints = accessor _endPoints (\es st -> st { _endPoints = es }) endPointAtIx :: EndPointIx -> Accessor RunState EndPoint endPointAtIx i = endPoints >>> listAccessor i connections :: Accessor RunState [(Connection, ConnectionInfo)] connections = accessor _connections (\cs st -> st { _connections = cs }) connectionAt :: ConnectionIx -> Accessor RunState (Connection, ConnectionInfo) connectionAt i = connections >>> listAccessor i expectedEvents :: Accessor RunState (Map EndPointAddress [ExpEvent]) expectedEvents = accessor _expectedEvents (\es st -> st { _expectedEvents = es }) expectedEventsAt :: EndPointAddress -> Accessor RunState [ExpEvent] expectedEventsAt addr = expectedEvents >>> DAC.mapDefault [] addr forwardingThreads :: Accessor RunState [ThreadId] forwardingThreads = accessor _forwardingThreads (\ts st -> st { _forwardingThreads = ts }) mayBreak :: EndPointAddress -> EndPointAddress -> BundleId -> Accessor RunState Bool mayBreak a b bid = aux >>> DAC.set (a, b, bid) where aux = accessor _mayBreak (\bs st -> st { _mayBreak = bs }) broken :: EndPointAddress -> EndPointAddress -> BundleId -> Accessor RunState Bool broken a b bid = aux >>> DAC.set (a, b, bid) where aux = accessor _broken (\bs st -> st { _broken = bs }) currentBundle :: EndPointAddress -> EndPointAddress -> Accessor RunState BundleId currentBundle i j = aux >>> if i < j then DAC.mapDefault 0 (i, j) else DAC.mapDefault 0 (j, i) where aux :: Accessor RunState (Map (EndPointAddress, EndPointAddress) BundleId) aux = accessor _currentBundle (\mp st -> st { _currentBundle = mp }) -------------------------------------------------------------------------------- -- Pretty-printing -- -------------------------------------------------------------------------------- verticalList :: Show a => [a] -> PP.Doc verticalList = PP.brackets . PP.vcat . map (PP.text . show) instance Show Script where show = ("\n" ++) . show . verticalList instance Show [Event] where show = ("\n" ++) . show . verticalList instance Show [ExpEvent] where show = ("\n" ++) . show . verticalList instance Show (Map EndPointAddress [ExpEvent]) where show = ("\n" ++) . show . PP.brackets . PP.vcat . map (\(addr, evs) -> PP.hcat . PP.punctuate PP.comma $ [PP.text (show addr), verticalList evs]) . Map.toList instance Show (Map EndPointAddress [Event]) where show = ("\n" ++) . show . PP.brackets . PP.vcat . map (\(addr, evs) -> PP.hcat . PP.punctuate PP.comma $ [PP.text (show addr), verticalList evs]) . Map.toList -------------------------------------------------------------------------------- -- Draw random values from probability distributions -- -------------------------------------------------------------------------------- data NormalD = NormalD { mean :: Double , stdDev :: Double } class Distribution d where probabilityOf :: d -> Double -> Double instance Distribution NormalD where probabilityOf d x = a * exp (-0.5 * b * b) where a = 1 / (stdDev d * sqrt (2 * pi)) b = (x - mean d) / stdDev d -- | Choose from a distribution chooseFrom :: Distribution d => d -> (Double, Double) -> Gen Double chooseFrom d (lo, hi) = findCandidate where findCandidate :: Gen Double findCandidate = do candidate <- choose (lo, hi) uniformSample <- choose (0, 1) if uniformSample < probabilityOf d candidate then return candidate else findCandidate chooseFrom' :: Distribution d => d -> (Int, Int) -> Gen Int chooseFrom' d (lo, hi) = round <$> chooseFrom d (fromIntegral lo, fromIntegral hi) -------------------------------------------------------------------------------- -- Auxiliary -------------------------------------------------------------------------------- log :: String -> IO () log = appendFile "log" . (++ "\n") logShow :: Show a => a -> IO () logShow = log . show instance Arbitrary ByteString where arbitrary = do len <- chooseFrom' NormalD { mean = 5, stdDev = 10 } (0, 100) xs <- replicateM len arbitrary return (pack xs) listAccessor :: Int -> Accessor [a] a listAccessor i = accessor (!! i) (error "listAccessor.set not defined") append :: Monad m => Accessor st [a] -> a -> StateT st m () append acc x = modify acc (snoc x) snoc :: a -> [a] -> [a] snoc x xs = xs ++ [x] groupByKey :: Ord a => [a] -> [(a, b)] -> Map a [b] groupByKey keys = go (Map.fromList [(key, []) | key <- keys]) where go acc [] = Map.map reverse acc go acc ((key, val) : rest) = go (Map.adjust (val :) key acc) rest -------------------------------------------------------------------------------- -- Expected failures (can't find explicit support for this in test-framework) -- -------------------------------------------------------------------------------- data ExpectedFailure = ExpectedFailure String deriving (Typeable, Show) instance Exception ExpectedFailure expectedFailure :: MonadIO m => String -> m () expectedFailure = liftIO . throwIO . ExpectedFailure