-- 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, testAll) 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 qualified Data.Traversable as T import Data.Unique import Prelude hiding (seq) import Control.Concurrent.CHP.Poison import Control.Concurrent.CHP.ProcessId -- | ClockSync was added in version 1.2.0. data RecordedEventType = ChannelComm | BarrierSync | ClockSync String 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 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,t) getEventUnique :: Event -> Unique getEventUnique (Event (u,_,_)) = u getEventTVar :: Event -> TVar (WithPoison (Int, Integer, [OfferSet])) getEventTVar (Event (_,_,tv)) = tv getEventType :: Event -> 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)) 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, 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) getAndIncCounter :: Event -> a -> STM (WithPoison Integer) getAndIncCounter e _ = 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 -- | 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)] , Map.Map Event (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, Map.Map Event ())] -> Maybe ( [(SignalVar, SignalValue)] , Map.Map Event (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 ns then act else (tv, 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 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 fst act) (repeat $ unionAll $ map allEventsInOffer allOffers) return (Map.mapKeysMonotonic getEventUnique 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 :: [(SignalValue, Map.Map Event ())] nullOffer = [(nullSignalValue,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 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 :: 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, an STM action to execute at the same time as the -- synchronisation, 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, 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)) 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, 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: ---------------------------------------------------------------------- ---------------------------------------------------------------------- -- 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 = [ (Signal $ NoPoison (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, 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 :: 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 . (*1000) . 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 (fst v /= (if poisoned then addPoison else id) (Signal $ NoPoison ((pn*1000)+en))) $ putStrLn $ 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 _ -> putStrLn $ testName ++ " Unexpected win for process: " ++ show n | 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 case x of NoPoison (c, _, e') | c == count && e' == expVal -> return () _ -> 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)