-- 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 (RecordedEventType(..), Event, getEventUnique, SignalVar, SignalValue(..), enableEvents, disableEvents, newEvent, newEventUnique, enrollEvent, resignEvent, poisonEvent, checkEventForPoison, getEventTypeVal #ifdef CHP_TEST , testAll #endif ) where import Control.Arrow 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 qualified Data.Traversable as T import Data.Unique import Prelude hiding (seq) #ifdef CHP_TEST import Test.HUnit hiding (test) #endif import Control.Concurrent.CHP.Poison import Control.Concurrent.CHP.ProcessId -- | The type of an event in the CSP and VCR traces. -- -- ClockSync was added in version 1.2.0. -- -- The extra parameter on ChannelComm and BarrierSync (which are the result of -- showing the value sent and phase ended respectively) was added in version 1.5.0. data RecordedEventType = ChannelComm String | BarrierSync String | ClockSync String deriving (Eq, Ord, Show) getEventTypeVal :: RecordedEventType -> String getEventTypeVal (ChannelComm s) = s getEventTypeVal (BarrierSync s) = s getEventTypeVal (ClockSync s) = s -- Not really a CSP event, more like an enrollable poisonable alting barrier! newtype Event = Event ( Unique, -- Event identifier STM RecordedEventType, -- Event type for trace recording TVar (WithPoison (Int, -- Enrolled count Integer, -- Event sequence 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) getEventUnique :: Event -> Unique getEventUnique (Event (u,_,_)) = u getEventTVar :: Event -> TVar (WithPoison (Int, Integer, [OfferSet])) getEventTVar (Event (_,_,tv)) = tv getEventType :: Event -> STM RecordedEventType getEventType (Event (_,t,_)) = t -- The value used to pass information to a waiting process once one of their events -- has fired (and they have been committed to it). The Int is an index into their -- list of guards newtype SignalValue = Signal (WithPoison Int) deriving (Eq, Show) type SignalVar = TVar (Maybe (SignalValue, Map.Map Unique (Integer, RecordedEventType))) addPoison :: SignalValue -> SignalValue addPoison = const $ Signal PoisonItem nullSignalValue :: SignalValue nullSignalValue = Signal $ NoPoison (-1) isNullSignal :: SignalValue -> Bool isNullSignal (Signal n) = n == NoPoison (-1) newtype OfferSet = OfferSet (SignalVar -- Variable to use to signal when committed , ProcessId -- Id of the process making the offer , [((SignalValue, STM ()), 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) instance Show OfferSet where show (OfferSet (_, pid, vs)) = "OfferSet " ++ show (pid, map (first fst) vs) -- 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 [] = Map.empty unionAll ms = foldl1 Map.union ms allEventsInOffer :: OfferSet -> Map.Map Event () allEventsInOffer (OfferSet (_, _, [(_,es)])) = es allEventsInOffer (OfferSet (_, _, eventSets)) = unionAll (map snd eventSets) getAndIncCounter :: Event -> (a, b) -> STM (WithPoison (Integer, a)) getAndIncCounter e (r, _) = do x <- readTVar (getEventTVar e) case x of PoisonItem -> return PoisonItem NoPoison (a, !n, c) -> do writeTVar (getEventTVar e) $ NoPoison (a, succ n, c) return $ NoPoison (n, r) -- | search is /not/ used for discovering offers. It is used for looking for possible -- resolutions to a collection of offer sets. It is pure; it performs no STM actions, -- it just searches the offer-sets (which will have been discovered through STM) -- for completions. -- -- search performs a 2-dimensional traversal of the offers. The search function -- is called with a list of offer-sets. For the offer-set at the head, it calls -- tryAll. tryAll searches through each offer in the offer-set, seeing if it can -- be completed. If it can, it calls search on the remaining offer-sets. If this -- fails, it reverts to trying the other offers in the list. The map of events passed through -- relates to the previous things found in the search. search :: [OfferSet] -- ^ The collection of all the related offer-sets -> Map.Map Event Bool -- ^ This contains the events already decided upon in the search. If -- an event maps to True, it means it was chosen by an earlier part of -- the search, and thus future parts of the search /must/ have this event -- in the chosen offer (if the process offers it at all -- if it doesn't, -- it can be ignored). If an event maps to False, it was already ruled -- out by not being chosen in another part of the search, and it cannot -- be chosen by any future parts of the search. Should be empty when first called from the outside. -> Maybe ( [(SignalVar, SignalValue, STM ())] , Map.Map Event (STM RecordedEventType, Set.Set ProcessId) ) -- ^ The list of tvars involved with the completion and the signal -- value for them, and the map with information about the completed events. search [] _ = Just ([], 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 ] -- Folds across a map, seeing if the given predicate holds for all values -- in the map. mapdotall :: Ord k => (a -> Bool) -> Map.Map k a -> Bool mapdotall f = Map.fold (\x b -> f x && b) True and' :: Ord k => Map.Map k Bool -> Bool and' = mapdotall id tryAll :: [((SignalValue, STM ()), Map.Map Event ())] -> Maybe ( [(SignalVar, SignalValue, STM ())] , Map.Map Event (STM RecordedEventType, Set.Set ProcessId) ) tryAll [] = Nothing tryAll ((ns, es):next) | not $ and' (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) -> Just (if isNullSignal (fst ns) then act else (tv, fst ns, snd ns) : act , foldl (\m e -> Map.insertWith add e (getEventType e, Set.singleton pid) m) resolved (Map.keys es) ) 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) -- 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 SignalVar -> [OfferSet] -> Set.Set Event -> STM (Map.Map Unique (RecordedEventType, Set.Set ProcessId)) resolveOffers newTvid allOffers events = do let (offers', _) = trim (allOffers, events) (act, ret) = fromMaybe ([], Map.empty) $ search (map addNullOffer $ sortOffers offers') Map.empty -- The associated event-action must come first as that puts the values in the channels: mapM_ (\(_, _, m) -> m) act -- These values are then read by these on-completion bits: ret' <- T.mapM (\(m,y) -> do x <- m return (x, y)) ret eventCounts <- T.sequence $ Map.mapWithKey getAndIncCounter ret' let NoPoison uniqCounts = T.sequence $ Map.mapKeysMonotonic getEventUnique eventCounts mapM_ (\(tv, x, _) -> writeTVar tv (Just (x, uniqCounts))) act -- do the retractions for all involved processes once the choice is made: -- TODO optimise: retractOffers $ zip (map fst3 act) (repeat $ unionAll $ map allEventsInOffer allOffers) return (Map.mapKeysMonotonic getEventUnique ret') where fst3 (x, _, _) = x -- 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 :: [((SignalValue, STM ()), Map.Map Event ())] nullOffer = [((nullSignalValue, return ()) ,Map.empty)] -- Smallest offers first to minimise backtracking: sortOffers :: [OfferSet] -> [OfferSet] sortOffers xs | length xs > 2 = sortBy (compare `on` (\(OfferSet (_,_,es)) -> length es)) xs | otherwise = 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 oe = (offers', events') in if changed then trim oe else oe where trimOffer :: (Set.Set Event, Bool) -> OfferSet -> ((Set.Set Event, Bool), OfferSet) trimOffer (es, changed) o@(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) | Set.size es == 1 = partition (\(_,x) -> Map.size x /= 1 || fst (Map.findMin x) /= Set.findMin es) eventSets | otherwise = 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 if null eventSetsToRemove then ((es, changed), o) else ((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)) -- If the offers only have one event, must be this -- one: (if Map.size (unionAll otherEvents) == 1 then next else next ++ zip (repeat $ return ()) (Map.keys $ unionAll otherEvents)) else -- No way it could be ready, so ignore it: discoverRelatedOffersAll a next -- Given 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 -- ^ Either an OfferSet to spider out from, or a single -- event. The latter case is for when we are resigning -- from an event and need to check if that completes anything. -> STM (WithPoison (Map.Map Unique (RecordedEventType, Set.Set ProcessId))) -- ^ Gives back either poison, or a map from event identifiers -- to information about the completed event. The map is -- empty if no events were completed. discoverAndResolve offOrEvent = do r <- discoverRelatedOffers $ case offOrEvent of Left off@(OfferSet (tv, _, nes)) -> let retract = retractOffers [(tv, allEventsInOffer off)] in concat [zip -- This is the action to execute if an event is found to -- be poisoned: (repeat $ retract >> writeTVar tv (Just (addPoison ns, Map.empty))) (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 :: STM RecordedEventType -> Int -> IO Event newEvent t n = do u <- newUnique atomically $ do tv <- newTVar (NoPoison (n, 0, [])) return $ Event (u, t, tv) newEventUnique :: IO Unique newEventUnique = newUnique enrollEvent :: Event -> STM (WithPoison ()) enrollEvent e = do x <- readTVar $ getEventTVar e case x of PoisonItem -> return PoisonItem NoPoison (count, seq, offers) -> do writeTVar (getEventTVar e) $ NoPoison (count + 1, seq, 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, seq, offers) -> do writeTVar (getEventTVar e) $ NoPoison (count - 1, seq, 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 that are associated with the given TVar; -- i.e. the TVar is used as an identifier for the process retractOffers :: [(SignalVar, Map.Map Event ())] -> STM () retractOffers = mapM_ retractAll where retractAll :: (SignalVar, 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, seq, offers) -> let reducedOffers = filter (\(OfferSet (tvx,_,_)) -> tvx /= tvid) offers in writeTVar (getEventTVar e) $ NoPoison (enrolled, seq, 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 -- No need for nub, as having it come from a map guarantees there are no -- duplicates in the list of events 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, seq, prevOffers) -> do writeTVar (getEventTVar e) $ NoPoison (count, seq, offers : prevOffers) return $ NoPoison () -- Returns Nothing if no events were ready. Returns Just with the signal value -- if an event was immediately available, followed by the information for each -- event involved in the synchronisation. If poison was encounted, this list will -- be empty. enableEvents :: SignalVar -- ^ Variable used to signal the process once a choice is made -> ProcessId -- ^ The id of the process making the choice -> [((SignalValue, STM ()), [Event])] -- ^ The list of options. Each option has a signalvalue to return -- if chosen, and a list of events (conjoined together). -- So this list is the disjunction of conjunctions, with a little -- more information. -> Bool -- ^ True if it can commit to waiting. If there is an event -- combination ready during the transaction, it will chosen regardless -- of the value of this flag. However, if there no events ready, -- passing True will leave the offers there, but False will retract -- the offers. -> STM (Maybe ((SignalValue, Map.Map Unique (Integer, RecordedEventType)), [((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]) -- First add our offer to all the events: -- We don't check the result for poison, as discoverAndResolve will find -- it anyway makeOffers offer -- Then spider out and see if anything can be resolved: 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]) -- | Given the variable used to signal the process, and the list of events that -- were involved in its offers, attempts to disable the events. If the variable -- has been signalled (i.e. has a Just value), that is returned and nothing is done, if the variable -- has not been signalled (i.e. is Nothing), the events are disabled and Nothing -- is returned. disableEvents :: SignalVar -> [Event] -> STM (Maybe (SignalValue, Map.Map Unique (Integer, RecordedEventType))) 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 (addPoison $ pickInts events, Map.empty)) | OfferSet (tvw, _, events) <- offers] writeTVar (getEventTVar e) PoisonItem where pickInts :: [((SignalValue, STM ()), Map.Map Event ())] -> SignalValue pickInts es = case filter ((e `Map.member`) . snd) es of [] -> nullSignalValue -- Should never happen (((ns,_),_):_) -> ns --TODO document how if it's poisoned, 0 will be appended to the list ---------------------------------------------------------------------- ---------------------------------------------------------------------- -- Testing: ---------------------------------------------------------------------- ---------------------------------------------------------------------- #ifdef CHP_TEST -- 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 :: Test testDiscover = TestCase $ 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 "Two separate events A, non-completable" [(NoPoison 2, False), (NoPoison 1, False)] [ (False, [[0]]), (False, [[1]]) ] [0] 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 | ((yes, _),off) <- zip offerSets realOffers, yes] ,Set.fromList [e | (e,(_count, present)) <- zip events eventCounts, present]) act <- atomically $ discoverRelatedOffers $ zip (repeat $ return ()) $ map (events!!) startEvents case act of PoisonItem -> assertFailure $ testName ++ "Unexpected poison" NoPoison actualResult -> do when (fst expectedResult **/=** fst actualResult) $ assertFailure $ testName ++ " failed offers, exp: " ++ show (length $ fst expectedResult) ++ " got: " ++ show (length $ fst actualResult) when (snd expectedResult /= snd actualResult) $ assertFailure $ 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 _ -> assertFailure $ testName ++ " expected poison but none" testTrim :: Test testTrim = TestCase $ 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, _) -> assertFailure $ testName ++ " expected poison but none found" (_, PoisonItem) -> assertFailure $ testName ++ " unexpected poison" (NoPoison expectedResult, NoPoison actualResult) -> do when (fst expectedResult **/=** fst actualResult) $ assertFailure $ testName ++ " failed offers, exp: " ++ show (length $ fst expectedResult) ++ " got: " ++ show (length $ fst actualResult) when (snd expectedResult /= snd actualResult) $ assertFailure $ testName ++ " failed events, exp: " ++ show (snd expectedResult) ++ "but got: " ++ show (snd actualResult) testPoison :: Test testPoison = TestCase $ 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) -> assertFailure $ testName ++ " expected no poison but found it" (PoisonItem, NoPoison _) -> assertFailure $ testName ++ " expected poison but found none" (NoPoison expOff, NoPoison (_, _, actOff)) -> when (map (realOffers !!) expOff **/=** actOff) $ assertFailure $ testName ++ " offers did not match" | (n, (_, expect)) <- zip [0..] eventCounts] testAll :: Test testAll = TestList [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 (return $ 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 -- TODO test the STM actions too offSub = [ ((Signal $ NoPoison (processN + offerN), return ()), 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, s, offs) -> writeTVar (getEventTVar e) $ NoPoison (count, s, off : offs) PoisonItem -> return () ) (Map.keys $ unionAll $ map snd offSub) return off | (processN, processOffers) <- zip (map (*1000) [0..]) offerSets] return (events, realOffers) testResolve :: Test testResolve = TestCase $ 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 -> -- List of events: [(WithPoison Int {- enrolled 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 <- liftM (liftM (fmap snd)) $ atomically $ discoverAndResolve $ Left $ head realOffers let expectedResult = if poisoned then PoisonItem else NoPoison $ Map.fromList [ (getEventUnique e, Set.fromList $ map (testProcessId . (*1000) . fst) is) | (e, Left is) <- zip events (map snd eventCounts)] when (expectedResult /= actualResult) $ assertFailure $ 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 -> assertFailure $ "Unexpected no-win for " ++ show (pn,en) Just v -> when (fst v /= (if poisoned then addPoison else id) (Signal $ NoPoison ((pn*1000)+en))) $ assertFailure $ testName ++ " wrong choice: " ++ " 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 _ -> assertFailure $ testName ++ " Unexpected win for process: " ++ show n | n <- [0 .. length offerSets - 1] \\ allFired] -- check events are blanked afterwards: c <- sequence [ let e = events !! n expVal = case st of Left _ -> [] Right ns -> map (realOffers !!) ns in do x <- atomically $ readTVar $ getEventTVar e case x of NoPoison (c, _, e') -> return $ Just ((count, expVal), (c, e')) _ -> do assertFailure $ testName ++ " unexpected poison" return Nothing {- NoPoison (c, _, e') | c == count && e' == expVal -> return () _ -> assertFailure $ 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] uncurry (assertEqual testName) (unzip $ catMaybes c) showStuff = show . fmap (map (first hashUnique) . Map.toList) #endif -- CHP_TEST