-- Communicating Haskell Processes. -- Copyright (c) 2008, University of Kent. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are -- met: -- -- * Redistributions of source code must retain the above copyright -- notice, this list of conditions and the following disclaimer. -- * Redistributions in binary form must reproduce the above copyright -- notice, this list of conditions and the following disclaimer in the -- documentation and/or other materials provided with the distribution. -- * Neither the name of the University of Kent nor the names of its -- contributors may be used to endorse or promote products derived from -- this software without specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, -- THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -- PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR -- CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --TODO document this (for internal purposes) module Control.Concurrent.CHP.Event where import Control.Concurrent.STM import Control.Monad import Data.Function import Data.List import qualified Data.Map as Map import Data.Maybe import qualified Data.Set as Set import Data.Unique import Control.Concurrent.CHP.Poison import Control.Concurrent.CHP.ProcessId data RecordedEventType = ChannelComm | BarrierSync deriving (Eq, Ord, Show) -- Not really a CSP event, more like an enrollable poisonable alting barrier! newtype Event = Event ( Unique, -- Event identifier RecordedEventType, -- Event type for trace recording TVar (WithPoison (Int, -- Enrolled count [OfferSet]) -- A list of offer sets )) instance Eq Event where (==) = (==) `on` getEventUnique instance Ord Event where compare = compare `on` getEventUnique -- For testing: instance Show Event where show (Event (u, t, _tv)) = "Event " ++ show (hashUnique u,t) getEventUnique :: Event -> Unique getEventUnique (Event (u,_,_)) = u getEventTVar :: Event -> TVar (WithPoison (Int, [OfferSet])) getEventTVar (Event (_,_,tv)) = tv getEventType :: Event -> RecordedEventType getEventType (Event (_,t,_)) = t newtype OfferSet = OfferSet (TVar (Maybe [Int]) -- Variable to use to signal when committed , ProcessId -- Id of the process making the offer , [([Int], Map.Map Event ())]) -- Value to send when committed -- A list of all sets of events currently offered instance Eq OfferSet where (==) = (==) `on` (\(OfferSet (tv,_,_)) -> tv) -- Each event in the map can have three possible values: -- PoisonItem; event is poisoned, can always be completed -- NoPoison True; event has been chosen by previous process, you must choose -- it too -- NoPoison False; event has been rejected by previous process, you cannot -- choose it unionAll :: Ord k => [Map.Map k a] -> Map.Map k a unionAll = foldl Map.union Map.empty allEventsInOffer :: OfferSet -> Map.Map Event () allEventsInOffer (OfferSet (_, _, eventSets)) = unionAll (map snd eventSets) search :: [OfferSet] -> Map.Map Event Bool -> Maybe (STM (), Map.Map Unique (RecordedEventType, Set.Set ProcessId), [(TVar (Maybe [Int]), [Event])]) search [] _ = Just (return (), Map.empty, []) search (offer@(OfferSet (tv, pid, eventSets)) : offers) eventMap | Map.null mustChooseFromEventSets = tryAll eventSets | otherwise = tryAll filteredEventSets where allEventsInOfferMappedToFalse :: Map.Map Event Bool allEventsInOfferMappedToFalse = Map.map (const False) (allEventsInOffer offer) mustChooseFromEventSets :: Map.Map Event Bool mustChooseFromEventSets = (Map.filter id {- Keep all True events -} eventMap) `Map.intersection` allEventsInOfferMappedToFalse -- Only the offers containing all of the mustChooseFromEventSets filteredEventSets = [ off | off@(_,es) <- eventSets, Map.isSubmapOfBy (\_ _ -> True) mustChooseFromEventSets es ] mapdotall :: Ord k => (a -> Bool) -> Map.Map k a -> Bool mapdotall f = Map.fold (\x b -> f x && b) True -- All events in the maps in the first parameter will be mapped to True tryAll :: [([Int],Map.Map Event ())] -> Maybe (STM (), Map.Map Unique (RecordedEventType, Set.Set ProcessId), [(TVar (Maybe [Int]), [Event])]) tryAll [] = Nothing tryAll ((ns, es):next) | not $ mapdotall id (eventMap `Map.intersection` es) -- Contains an already-rejected event (one that mapped to False), skip: -- Need to reject the other events too though -- well, at least put -- them in the appropriate map and pass them through. They will -- only be rejected if they are then not contained in the other chosen -- offer = tryAll next | otherwise = case search offers eventMap' of Nothing -> tryAll next Just (act, resolved, retract) -> Just (if null ns then act else writeTVar tv (Just ns) >> act, foldl (\m e -> Map.insertWith add (getEventUnique e) (getEventType e, Set.singleton pid) m) resolved (Map.keys es), if null ns then retract else (tv, Map.keys allEventsInOfferMappedToFalse) : retract) where -- All events that features in other offers by this process, but not -- the current offer -- -- It is very important here that union is left-biased for both unions. We don't want -- to overwrite poison with acceptance, or acceptance with rejection. eventMap' = (eventMap `Map.union` (Map.map (const True) es)) `Map.union` allEventsInOfferMappedToFalse add (tx, pidsx) (_, pidsy) = (tx, pidsx `Set.union` pidsy) data EventStatus = Fine | NotCompletable deriving (Eq, Show) -- Given a list of offers that could possibly complete, check if any set -- of offers can. If so, complete it (including all retractions and -- notifications for each process), otherwise leave things untouched. -- -- Takes an optional tvar identifier for the newest process to make an offer, the -- list of all offer-sets that need to be considered (they will have come from -- all events in a connected sub-graph), the map of relevant events to their status, -- and returns the map of event-identifiers that did complete. resolveOffers :: Maybe (TVar (Maybe [Int])) -> [OfferSet] -> Set.Set Event -> STM (Map.Map Unique (RecordedEventType, Set.Set ProcessId)) resolveOffers newTvid allOffers events = do let (offers', _) = trim (allOffers, events) (act, ret, retract) = fromMaybe (return (), Map.empty, []) $ search (map addNullOffer $ sortOffers offers') Map.empty act -- do the retractions for all involved processes once the choice is made: -- TODO optimise: retractOffers $ zip (map fst retract) (repeat $ unionAll $ map allEventsInOffer allOffers) return ret where -- Don't add the null offer for the newest process, and null offer should be -- added to the end: addNullOffer :: OfferSet -> OfferSet addNullOffer (OfferSet (tv,y,zs)) = OfferSet (tv,y,if Just tv == newTvid then zs else zs++nullOffer) nullOffer :: [([Int], Map.Map Event ())] nullOffer = [([],Map.empty)] -- SMallest offers first to minimise backtracking: sortOffers :: [OfferSet] -> [OfferSet] sortOffers xs = sortBy (compare `on` (\(OfferSet (_,_,es)) -> length es)) xs -- TODO put the newest process first again -- Given a list of offer-sets, and a map of events already-looked-at to their status, -- trims the offer-sets by removing any option in an offer-set that cannot possibly -- complete. If this option includes any other events, any other options anywhere -- that also feature these must be removed too. The function iterates until it -- finds a fix-point. trim :: ([OfferSet], Set.Set Event) -> ([OfferSet], Set.Set Event) -- Each iteration, we remove all offersets that reference events that can -- never be ready, and if the removing of any of those causes an event -- to never become ready, we remove those events too, then we'll go round -- again (while finding the fix point) trim (offers, events) = let ((events', changed), offers') = mapAccumL trimOffer (events, False) offers in (if changed then trim else id) (offers', events') where trimOffer :: (Set.Set Event, Bool) -> OfferSet -> ((Set.Set Event, Bool), OfferSet) trimOffer (es, changed) (OfferSet (tv, pid, eventSets)) -- An offer is only retained if all the events are in the set of events -- that can possibly complete = let (eventSetsToRemove, eventSetsTrimmed) = partition (\(_,x) -> not $ (Map.keysSet x) `Set.isSubsetOf` es) eventSets -- If any of the events to remove are not also in sets that will -- be kept, and the event is not poisoned, that event is no longer completable and should be -- removed from the set of events: eventsNotCompletable = Map.keysSet $ (unionAll $ map snd eventSetsToRemove) `Map.difference` (unionAll $ map snd eventSetsTrimmed) changed' = changed || not (null eventSetsToRemove) in ((es `Set.difference` eventsNotCompletable, changed'), OfferSet (tv, pid, eventSetsTrimmed)) -- Semantics of poison with waiting for multiple events is that if /any/ of -- the events are poisoned, that whole offer will be available immediately -- even if the other channels are not ready, and the body will throw a poison -- exception rather than running any of the guards. This is because in situations -- where for example you want to wait for two inputs (e.g. invisible process -- or philosopher's forks) you usually want to forward poison from one onto -- the other. -- Finds all the events that could be linked to the given one. -- -- Given an event, spiders out and discovers all events (connected via mutual offers). -- Returns the list of offer-sets found. It also -- returns a set containing each connected completable event. -- If any of the events are found to be poisoned, the associated STM action is -- executed discoverRelatedOffers :: [(STM (), Event)] -> STM (WithPoison ([OfferSet], Set.Set Event)) discoverRelatedOffers = discoverRelatedOffersAll $ NoPoison ([], Set.empty) where -- We need the supplied STM () actions for each event to take precedence over -- the default ones supplied later in the algorithm. So if, for example, the -- user supplies a,b and c in the list, but our usual depth-first search would -- lead a -> d -> c, we do not want to use the default event for c instead -- of the supplied one. Therefore we maintain the work list explicitly. -- Nothing means that that event is poisoned (and thus always ready) discoverRelatedOffersAll :: WithPoison ([OfferSet], Set.Set Event) -> [(STM (), Event)] -> STM (WithPoison ([OfferSet], Set.Set Event)) discoverRelatedOffersAll PoisonItem _ = return PoisonItem discoverRelatedOffersAll x [] = return x discoverRelatedOffersAll a@(NoPoison (accum, events)) ((act,e@(Event (_, _, tv))):next) -- Don't process the same event multiple times: | e `Set.member` events = discoverRelatedOffersAll a next | otherwise = do x <- readTVar tv case x of PoisonItem -> act >> return PoisonItem NoPoison (count, offers) -> let otherEvents = map allEventsInOffer offers in if length offers == count then -- It could be ready discoverRelatedOffersAll (NoPoison (accum ++ offers, Set.insert e events)) (next ++ zip (repeat $ return ()) (Map.keys $ unionAll otherEvents)) else -- No way it could be ready, so ignore it: discoverRelatedOffersAll a next -- Given an optional waiting-tvar from the newest process to offer (if any), and -- an event, spiders out, discovers all the offers, then resolves them and returns -- a map containing all the completed events, mapping the identifier to the event -- type and the set of process identifiers that participated in the succesfully -- completed events. The map will be empty if and only if no events were completed. discoverAndResolve :: Either OfferSet Event -> STM (WithPoison (Map.Map Unique (RecordedEventType,Set.Set ProcessId))) discoverAndResolve offOrEvent = do r <- discoverRelatedOffers $ case offOrEvent of Left off@(OfferSet (tv, _, nes)) -> let retract = retractOffers [(tv, allEventsInOffer off)] in concat [zip (repeat $ retract >> writeTVar tv (Just $ ns ++ [0])) (Map.keys es) | (ns, es) <- nes] Right e -> [(return (), e)] case r of PoisonItem -> return PoisonItem NoPoison (m, s) -> liftM NoPoison $ resolveOffers tvid (nub m) s where tvid = case offOrEvent of Left (OfferSet (tv, _, _)) -> Just tv _ -> Nothing newEvent :: RecordedEventType -> Int -> IO Event newEvent t n = do u <- newUnique atomically $ do tv <- newTVar (NoPoison (n, [])) return $ Event (u, t, tv) enrollEvent :: Event -> STM (WithPoison ()) enrollEvent e = do x <- readTVar $ getEventTVar e case x of PoisonItem -> return PoisonItem NoPoison (count, offers) -> do writeTVar (getEventTVar e) $ NoPoison (count + 1, offers) return $ NoPoison () -- If the event completes, we return details related to it: resignEvent :: Event -> STM (WithPoison [((RecordedEventType, Unique), Set.Set ProcessId)]) resignEvent e = do x <- readTVar $ getEventTVar e case x of PoisonItem -> return PoisonItem NoPoison (count, offers) -> do writeTVar (getEventTVar e) $ NoPoison (count - 1, offers) if (count - 1 == length offers) then liftM (fmap $ \mu -> [((r,u),pids) | (u,(r,pids)) <- Map.toList mu]) $ discoverAndResolve $ Right e else return $ NoPoison [] -- Given the list of identifiers paired with all the events that that process might -- be engaged in, retracts all the offers during a transaction. retractOffers :: [(TVar (Maybe [Int]), Map.Map Event ())] -> STM () retractOffers = mapM_ retractAll where retractAll :: (TVar (Maybe [Int]), Map.Map Event ()) -> STM () retractAll (tvid, evts) = mapM_ retract (Map.keys evts) where retract :: Event -> STM () retract e = do x <- readTVar $ getEventTVar e case x of PoisonItem -> return () NoPoison (enrolled, offers) -> let reducedOffers = filter (\(OfferSet (tvx,_,_)) -> tvx /= tvid) offers in writeTVar (getEventTVar e) $ NoPoison (enrolled, reducedOffers) -- Simply adds the offers but doesn't check if that will complete an event: -- Returns PoisonItem if any of the events were poisoned makeOffers :: OfferSet -> STM (WithPoison ()) makeOffers offers = do let allEvents = Map.keys $ allEventsInOffer offers liftM mergeWithPoison $ mapM makeOffer allEvents where makeOffer :: Event -> STM (WithPoison ()) makeOffer e = do x <- readTVar $ getEventTVar e case x of PoisonItem -> return PoisonItem NoPoison (count, prevOffers) -> do writeTVar (getEventTVar e) $ NoPoison (count, offers : prevOffers) return $ NoPoison () -- Passed: True if allowed to commit to waiting -- Returns: True if committed, False otherwise enableEvents :: TVar (Maybe [Int]) -> ProcessId -> [([Int], STM (), [Event])] -> Bool -> STM (Maybe ([Int], [((RecordedEventType, Unique), Set.Set ProcessId)])) enableEvents tvNotify pid events canCommitToWait = do let offer = OfferSet (tvNotify, pid, [(nid, Map.fromList (zip es (repeat ()))) | (nid, _, es) <- events]) makeOffers offer pmu <- discoverAndResolve (Left offer) case (canCommitToWait, pmu) of (_, PoisonItem) -> do Just chosen <- readTVar tvNotify return $ Just (chosen, []) (True, NoPoison mu) | Map.null mu -> return Nothing (False, NoPoison mu) | Map.null mu -> do retractOffers [(tvNotify, Map.fromList $ zip es (repeat ())) | (_,_,es) <- events] return Nothing (_, NoPoison mu) -> -- Need to turn all the Unique ids back into the custom-typed -- parameter that the user gave in the list. We assume -- it will be present: do {- let y = mapMaybe (\(k,v) -> listToMaybe [(x,v) | (x,_,_,es) <- events, k `elem` map getEventUnique es]) $ Map.toList mu -} Just chosen <- readTVar tvNotify return $ Just (chosen, [((r,u),pids) | (u,(r,pids)) <- Map.toList mu]) disableEvents :: TVar (Maybe [Int]) -> [Event] -> STM (Maybe [Int]) disableEvents tv events = do x <- readTVar tv -- Since the transaction will be atomic, we know -- now that we can disable the barriers and nothing fired: when (isNothing x) $ retractOffers [(tv, Map.fromList $ zip events (repeat ()))] return x checkEventForPoison :: Event -> STM (WithPoison ()) checkEventForPoison e = do x <- readTVar $ getEventTVar e case x of PoisonItem -> return PoisonItem _ -> return (NoPoison ()) poisonEvent :: Event -> STM () poisonEvent e = do x <- readTVar $ getEventTVar e case x of PoisonItem -> return () NoPoison (_, offers) -> do retractOffers [(tvw, unionAll $ map snd events) | OfferSet (tvw, _, events) <- offers] sequence_ [writeTVar tvw (Just $ pickInts events ++ [0]) | OfferSet (tvw, _, events) <- offers] writeTVar (getEventTVar e) PoisonItem where pickInts :: [([Int], Map.Map Event ())] -> [Int] pickInts es = case filter ((e `Map.member`) . snd) es of [] -> [] -- Should never happen ((ns,_):_) -> ns --TODO document how if it's poisoned, 0 will be appended to the list ---------------------------------------------------------------------- ---------------------------------------------------------------------- -- Testing: ---------------------------------------------------------------------- ---------------------------------------------------------------------- -- Tests if two lists have the same elements, but not necessarily in the same order: (**==**) :: Eq a => [a] -> [a] -> Bool a **==** b = (length a == length b) && (null $ a \\ b) (**/=**) :: Eq a => [a] -> [a] -> Bool a **/=** b = not $ a **==** b testDiscover :: IO () testDiscover = do test "Empty discover" [(NoPoison 1, False)] [] [0] test "Single full event" [(NoPoison 1, True)] [(True, [[0]])] [0] test "Two separate events A" [(NoPoison 1, True), (NoPoison 1, False)] [ (True, [[0]]), (False, [[1]]) ] [0] test "Two separate events B" [(NoPoison 1, False), (NoPoison 1, True)] [ (False, [[0]]), (True, [[1]]) ] [1] test "Three channels, linked by two OR-offerers" [(NoPoison 2, False), (NoPoison 2, True), (NoPoison 2, False)] (zip (repeat True) [ [[0],[1]] , [[1],[2]] ]) [1,2] test "Three channels, linked by two AND-offerers" [(NoPoison 2, False), (NoPoison 2, True), (NoPoison 2, False)] (zip (repeat True) [ [[0,1]] , [[1,2]] ]) [0,1] test "Three barriers, one process offering all pairs" (replicate 3 (NoPoison 2, False)) [(False,[ [0,1], [0,2], [1,2] ])] [0] -- Discovery on a poisoned event will not find offers associated with -- that event because they are not stored. The local offer is added -- in discoverAndResolve, not testDiscover, so for poison we expect -- to find nothing: test_Poison "Single poisoned event" [PoisonItem] [ [[0]] ] [0] test_Poison "Two poisoned events" [PoisonItem, PoisonItem] [ [[0,1]] ] [0,1] test_Poison "One poisoned, one non-poisoned event" [PoisonItem, NoPoison 1] [ [[0,1]] ] [0,1] where test :: String -> {- Events: -} [(WithPoison Int {-count -}, Bool {- Should be in set -})] -> {- Offers: -} [(Bool, [[Int] {- events -}])] -> {-Starting events: -} [Int] -> IO () test testName eventCounts offerSets startEvents = do (events, realOffers) <- makeTestEvents (map fst eventCounts) (map snd offerSets) let expectedResult = ([off | (n,off) <- zip [0..] realOffers, fst $ offerSets !! n] ,Set.fromList [events !! n | (n,(_count, present)) <- zip [0..] eventCounts, present]) act <- atomically $ discoverRelatedOffers $ zip (repeat $ return ()) $ map (events!!) startEvents case act of PoisonItem -> putStrLn $ testName ++ "Unexpected poison" NoPoison actualResult -> do when (fst expectedResult **/=** fst actualResult) $ putStrLn $ testName ++ " failed offers, exp: " ++ show (length $ fst expectedResult) ++ " got: " ++ show (length $ fst actualResult) when (snd expectedResult /= snd actualResult) $ putStrLn $ testName ++ " failed events " ++ "exp: " ++ show (snd expectedResult) ++ "but got: " ++ show (snd actualResult) test_Poison :: String -> {- Events: -} [WithPoison Int {-count -}] -> {- Offers: -} [[[Int] {- events -}]] -> {-Starting events: -} [Int] -> IO () test_Poison testName eventCounts offerSets startEvents = do (events, _realOffers) <- makeTestEvents eventCounts offerSets act <- atomically $ discoverRelatedOffers $ zip (repeat $ return ()) (map (events!!) startEvents) case act of PoisonItem -> return () NoPoison _ -> putStrLn $ testName ++ " expected poison but none" testTrim :: IO () testTrim = do test "Empty trim" [(NoPoison 1, False)] [] [0] test "Trim, Three channels, linked by two OR-offerers" [(NoPoison 2, False), (NoPoison 2, True), (NoPoison 2, False)] [ [(False, [0]), (True, [1])] , [(True, [1]), (False, [2])] ] [1] test "Trim, simplified santa not complete" (replicate 4 (NoPoison 2, False)) [ zip (repeat False) [[0,1,2],[0,1,3],[0,2,3],[1,2,3]], [(False, [0])], [(False, [1])]] [0] test "Trim, simplified santa complete" (replicate 3 (NoPoison 2, True) ++ [(NoPoison 2, False)]) [ [(True,[0,1,2]),(False,[0,1,3]),(False,[0,2,3]),(False,[1,2,3])], [(True, [0])], [(True, [1])], [(True, [2])]] [0] where test :: String -> {- Events: -} [(WithPoison Int {-count -}, Bool {- expected kept -})] -> {- Offers: -} [ [(Bool, [Int]) {- events -}]] -> {-Starting events:-} [Int] -> IO () test testName eventCounts offerSets startEvents = do (events, realOffers) <- makeTestEvents (map fst eventCounts) (map (map snd) offerSets) let expectedResult' = NoPoison $ ([OfferSet (tv,pid,[off | (m,off) <- zip [0..] offs, fst $ offerSets !! n !! m]) | (n,OfferSet (tv,pid,offs)) <- zip [0..] realOffers] ,Set.fromList [events !! n | (n,(_count, present)) <- zip [0..] eventCounts, present]) actualResult' <- liftM (fmap $ trim . (\(xs,y) -> (nub $ maybe id (:) (listToMaybe realOffers) xs, y))) $ atomically $ discoverRelatedOffers $ zip (repeat $ return ()) (map (events!!) startEvents) case (expectedResult', actualResult') of (PoisonItem, PoisonItem) -> return () (PoisonItem, _) -> putStrLn $ testName ++ " expected poison but none found" (_, PoisonItem) -> putStrLn $ testName ++ " unexpected poison" (NoPoison expectedResult, NoPoison actualResult) -> do when (fst expectedResult **/=** fst actualResult) $ putStrLn $ testName ++ " failed offers, exp: " ++ show (length $ fst expectedResult) ++ " got: " ++ show (length $ fst actualResult) when (snd expectedResult /= snd actualResult) $ putStrLn $ testName ++ " failed events, exp: " ++ show (snd expectedResult) ++ "but got: " ++ show (snd actualResult) testPoison :: IO () testPoison = do test "Poison empty event" [(NoPoison 2, PoisonItem)] [] 0 test "Poison, single offerer" [(NoPoison 2, PoisonItem)] [[[0]]] 0 test "Poison, offered on two (AND)" [(NoPoison 2, PoisonItem), (NoPoison 2, NoPoison [])] [[[0,1]]] 0 test "Poison, offered on two (OR)" [(NoPoison 2, PoisonItem), (NoPoison 2, NoPoison [])] [[[0],[1]]] 0 where test :: String -> [(WithPoison Int {-count -}, WithPoison [Int] {- remaining offers -})] -> {- Offers: -} [[[Int] {- events -}]] -> Int {-Poison Event-} -> IO () test testName eventCounts offerSets poisoned = do (events, realOffers) <- makeTestEvents (map fst eventCounts) offerSets atomically $ poisonEvent $ events !! poisoned -- Now we must check that the event is poisoned, and that all processes -- that were offering on that event have had their offers retracted (by -- checking that only the specified offers remain on each event) sequence_ [do x <- atomically $ readTVar $ getEventTVar $ events !! n case (expect, x) of (PoisonItem, PoisonItem) -> return () (NoPoison _, PoisonItem) -> putStrLn $ testName ++ " expected no poison but found it" (PoisonItem, NoPoison _) -> putStrLn $ testName ++ " expected poison but found none" (NoPoison expOff, NoPoison (_, actOff)) -> when (map (realOffers !!) expOff **/=** actOff) $ putStrLn $ testName ++ " offers did not match" | (n, (_, expect)) <- zip [0..] eventCounts] testAll :: IO () testAll = testDiscover >> testTrim >> testResolve >> testPoison makeTestEvents :: {- Events: -} [WithPoison Int {-count -}] -> {- Offers: -} [[[Int] {- events -}]] -> IO ([Event], [OfferSet]) -- Offers is a list of list of list of ints -- Outermost list is one-per-process -- Middle list is one-per-offer -- Inner list is a conjunction of events makeTestEvents eventCounts offerSets = do events <- mapM (\n -> newEvent ChannelComm $ case n of NoPoison n' -> n' PoisonItem -> 0) eventCounts -- Poison all the events marked as poisoned: atomically $ sequence_ [writeTVar tv PoisonItem | (n,Event (_,_,tv)) <- zip [0..] events, eventCounts !! n == PoisonItem] realOffers <- sequence [ do tv <- atomically $ newTVar Nothing let pid = testProcessId processN offSub = [ ([processN, offerN], Map.fromList [ (events !! indivEvent, ()) | indivEvent <- singleOffer]) | (offerN, singleOffer) <- zip [0..] processOffers] off = OfferSet (tv, pid, offSub) mapM_ (\e -> atomically $ do x <- readTVar (getEventTVar e) case x of NoPoison (count, offs) -> writeTVar (getEventTVar e) $ NoPoison (count, off : offs) PoisonItem -> return () ) (Map.keys $ unionAll $ map snd offSub) return off | (processN, processOffers) <- zip [0..] offerSets] return (events, realOffers) testResolve :: IO () testResolve = do test "Empty Resolve" [(NoPoison 0, Right [])] [[]] test "Single offer" [(NoPoison 1, Left [(0,0)])] [[[0]]] test "Not enough" [(NoPoison 2, Right [0])] [[[0]]] test "One channel" [(NoPoison 2, Left [(0,0),(1,0)])] [[[0]],[[0]]] test "Two channels, two single offerers and one double" [(NoPoison 2, Left [(0,0),(2,0)]), (NoPoison 2, Left [(1,0),(2,0)])] [ [[0]], [[1]], [[0,1]] ] test "Two channels, two single offerers and one choosing" [(NoPoison 2, Left [(0,0),(2,0)]), (NoPoison 2, Right [1])] [ [[0]], [[1]], [[0],[1]] ] test "Three channels, both offering different pair" [(NoPoison 2, Right []), (NoPoison 2, Left [(0,1),(1,0)]), (NoPoison 2, Right [])] [ [[0],[1]] , [[1],[2]] ] -- This test is a bit hacky, given there are two valid results: test "Two channels, both could complete" [(NoPoison 2, Left [(0,0),(1,0)]), (NoPoison 2, Right [])] [ [[0],[1]] , [[0],[1]] ] test "Three channels, any could complete" [(NoPoison 2, Left [(0,0),(1,0)]), (NoPoison 2, Right [2]), (NoPoison 2, Right [2])] [ [[0],[1]] , [[0],[2]], [[1],[2]] ] test "Three channels, one guy offering three pairs, two single offerers" [(NoPoison 2, Left [(0,1),(1,0)]), (NoPoison 2, Right []), (NoPoison 2, Left [(0,1),(2,0)])] [ [[0,1],[0,2],[1,2]], [[0]], [[2]] ] test "Three channels, one guy offering three pairs, three single offerers" [(NoPoison 2, Left [(0,0),(1,0)]), (NoPoison 2, Left [(0,0),(2,0)]), (NoPoison 2, Right [3])] [ [[0,1],[0,2],[1,2]], [[0]], [[1]], [[2]] ] test "Four channels, one guy offering sets of three, three single offerers" [(NoPoison 2, Left [(0,0),(1,0)]), (NoPoison 2, Left [(0,0),(2,0)]), (NoPoison 2, Left [(0,0),(3,0)]), (NoPoison 2, Right [])] [ [[0,1,2],[0,1,3],[0,2,3],[1,2,3]], [[0]], [[1]], [[2]] ] test "Four channels, one guy offering sets of three, two single offerers" [(NoPoison 2, Right [1,0]), (NoPoison 2, Right [2,0]), (NoPoison 2, Right [0]), (NoPoison 2, Right [0])] [ [[0,1,2],[0,1,3],[0,2,3],[1,2,3]], [[0]], [[1]] ] -- test resolutions with poison: -- test' "One event, poisoned" [(PoisonItem, Left [(0,0)])] [[[0]]] True test' "Two events, one poisoned" [(PoisonItem, Left [(0,0)]), (NoPoison 2, Left [(0,0)])] [[[0,1]]] True where test testName eventCounts offerSets = test' testName eventCounts offerSets False test' :: String -> [(WithPoison Int {-count -}, Either [(Int, Int)] {- success: expected process, offer indexes -} [Int] {- remaining offers -})] -> {- Offers: -} [[[Int] {- events -}]] -> Bool {-Poisoned-} -> IO () test' testName eventCounts offerSets poisoned = do (events, realOffers) <- makeTestEvents (map fst eventCounts) offerSets actualResult <- atomically $ discoverAndResolve $ Left $ head realOffers let expectedResult = if poisoned then PoisonItem else NoPoison $ Map.fromList [ (getEventUnique e, (ChannelComm, Set.fromList $ map (testProcessId . fst) is)) | (e, Left is) <- zip events (map snd eventCounts)] when (expectedResult /= actualResult) $ putStrLn $ testName ++ " failed on direct result, expected: " ++ showStuff expectedResult ++ " got: " ++ showStuff actualResult allFired <- liftM concat $ mapM (flip either (const $ return []) $ mapM $ \(pn, en) -> let OfferSet (tv,_,_) = realOffers !! pn in do x <- atomically $ readTVar tv case x of Nothing -> putStrLn $ "Unexpected no-win for " ++ show (pn,en) Just v -> when (v /= (if poisoned then (++[0]) else id) [pn, en]) $ putStrLn $ testName ++ " wrong choice: " ++ show v ++ " exp: " ++ show [pn, en] return pn ) $ map snd eventCounts -- test the others are unchanged sequence_ [ let OfferSet (tv,_,_) = realOffers !! n in do x <- atomically $ readTVar tv case x of Nothing -> return () Just _ -> putStrLn $ testName ++ " Unexpected win for process: " ++ show n ++ " " ++ show x | n <- [0 .. length offerSets - 1] \\ allFired] -- check events are blanked afterwards: sequence_ [ let e = events !! n expVal = case st of Left _ -> [] Right ns -> map (realOffers !!) ns in do x <- atomically $ readTVar $ getEventTVar e when (x /= NoPoison (count, expVal)) $ putStrLn $ testName ++ "Event " ++ show n ++ " not as expected after, exp: " ++ show (length expVal) ++ " act: " ++ (let NoPoison (_,act) = x in show (length act)) | (n,(NoPoison count, st)) <- zip [0..] eventCounts] showStuff = show . fmap (map (\(u,x) -> (hashUnique u, x)) . Map.toList)