| {-# LANGUAGE TemplateHaskell #-} |
| {-# OPTIONS_GHC -fno-warn-orphans #-} |
| |
| {-| Tests for lock waiting structure. |
| |
| -} |
| |
| {- |
| |
| Copyright (C) 2014 Google Inc. |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are |
| met: |
| |
| 1. Redistributions of source code must retain the above copyright notice, |
| this list of conditions and the following disclaimer. |
| |
| 2. 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. |
| |
| 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 HOLDER 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. |
| |
| -} |
| |
| module Test.Ganeti.Locking.Waiting (testLocking_Waiting) where |
| |
| import Prelude () |
| import Ganeti.Prelude |
| |
| import Control.Applicative (liftA2) |
| import Control.Monad (liftM) |
| import qualified Data.Map as M |
| import qualified Data.Set as S |
| import qualified Text.JSON as J |
| |
| import Test.QuickCheck |
| |
| import Test.Ganeti.TestCommon |
| import Test.Ganeti.TestHelper |
| import Test.Ganeti.Locking.Allocation (TestLock, TestOwner, requestSucceeded) |
| |
| import Ganeti.BasicTypes (isBad, genericResult, runListHead) |
| import Ganeti.Locking.Allocation (LockRequest, listLocks) |
| import qualified Ganeti.Locking.Allocation as L |
| import Ganeti.Locking.Types (Lock) |
| import Ganeti.Locking.Waiting |
| |
| {- |
| |
| Ganeti.Locking.Waiting is polymorphic in the types of locks, lock owners, |
| and priorities. So we can use much simpler types here than Ganeti's |
| real locks and lock owners, knowning that polymorphic functions cannot |
| exploit the simplicity of the types they're deling with. To avoid code |
| duplication, we use the test structure from Test.Ganeti.Locking.Allocation. |
| |
| -} |
| |
| {- |
| |
| All states of a LockWaiting ever available outside the module can be |
| obtained from @emptyWaiting@ applying one of the update operations. |
| |
| -} |
| |
| data UpdateRequest a b c = Update b [LockRequest a] |
| | UpdateWaiting c b [LockRequest a] |
| | RemovePending b |
| | IntersectRequest b [a] |
| | OpportunisticUnion b [(a, L.OwnerState)] |
| deriving Show |
| |
| instance (Arbitrary a, Arbitrary b, Arbitrary c) |
| => Arbitrary (UpdateRequest a b c) where |
| arbitrary = |
| frequency [ (2, Update <$> arbitrary <*> (choose (1, 4) >>= vector)) |
| , (4, UpdateWaiting <$> arbitrary <*> arbitrary |
| <*> (choose (1, 4) >>= vector)) |
| , (1, RemovePending <$> arbitrary) |
| , (1, IntersectRequest <$> arbitrary |
| <*> (choose (1, 4) >>= vector)) |
| , (1, OpportunisticUnion <$> arbitrary |
| <*> (choose (1, 4) >>= vector)) |
| ] |
| |
| -- | Transform an UpdateRequest into the corresponding state transformer. |
| asWaitingTrans :: (Lock a, Ord b, Ord c) |
| => LockWaiting a b c -> UpdateRequest a b c -> LockWaiting a b c |
| asWaitingTrans state (Update owner req) = fst $ updateLocks owner req state |
| asWaitingTrans state (UpdateWaiting prio owner req) = |
| fst $ updateLocksWaiting prio owner req state |
| asWaitingTrans state (RemovePending owner) = removePendingRequest owner state |
| asWaitingTrans state (IntersectRequest owner locks) = |
| fst $ intersectLocks locks owner state |
| asWaitingTrans state (OpportunisticUnion owner locks) = |
| fst $ opportunisticLockUnion owner locks state |
| |
| |
| -- | Fold a sequence of requests to transform a waiting strucutre onto the |
| -- empty waiting. As we consider all exported transformations, any waiting |
| -- structure can be obtained this way. |
| foldUpdates :: (Lock a, Ord b, Ord c) |
| => [UpdateRequest a b c] -> LockWaiting a b c |
| foldUpdates = foldl asWaitingTrans emptyWaiting |
| |
| instance (Arbitrary a, Lock a, Arbitrary b, Ord b, Arbitrary c, Ord c) |
| => Arbitrary (LockWaiting a b c) where |
| arbitrary = foldUpdates <$> (choose (0, 8) >>= vector) |
| |
| -- | Verify that an owner with a pending request cannot make any |
| -- changes to the lock structure. |
| prop_NoActionWithPendingRequests :: Property |
| prop_NoActionWithPendingRequests = |
| forAll (arbitrary :: Gen TestOwner) $ \a -> |
| forAll ((arbitrary :: Gen (LockWaiting TestLock TestOwner Integer)) |
| `suchThat` (S.member a . getPendingOwners)) $ \state -> |
| forAll (arbitrary :: Gen [LockRequest TestLock]) $ \req -> |
| forAll arbitrary $ \prio -> |
| counterexample "Owners with pending requests may not update locks" |
| . all (isBad . fst . snd) |
| $ [updateLocks, updateLocksWaiting prio] <*> [a] <*> [req] <*> [state] |
| |
| -- | Quantifier for blocked requests. Quantifies over the generic situation |
| -- that there is a state, an owner, and a request that is blocked for that |
| -- owner. To obtain such a situation, we use the fact that there must be a |
| -- different owner having at least one lock. |
| forAllBlocked :: (Testable prop) |
| => (LockWaiting TestLock TestOwner Integer -- State |
| -> TestOwner -- The owner of the blocked request |
| -> Integer -- The priority |
| -> [LockRequest TestLock] -- Request |
| -> prop) |
| -> Property |
| forAllBlocked predicate = |
| forAll (arbitrary :: Gen TestOwner) $ \a -> |
| forAll (arbitrary :: Gen Integer) $ \prio -> |
| forAll (arbitrary `suchThat` (/=) a) $ \b -> |
| forAll ((arbitrary :: Gen (LockWaiting TestLock TestOwner Integer)) |
| `suchThat` foldl (liftA2 (&&)) (const True) |
| [ not . S.member a . getPendingOwners |
| , M.null . listLocks a . getAllocation |
| , not . M.null . listLocks b . getAllocation]) $ \state -> |
| forAll ((arbitrary :: Gen [LockRequest TestLock]) |
| `suchThat` (genericResult (const False) (not . S.null) |
| . fst . snd . flip (updateLocksWaiting prio a) state)) |
| $ \req -> |
| predicate state a prio req |
| |
| -- | Verify that an owner has a pending request after a waiting request |
| -- not fullfilled immediately. |
| prop_WaitingRequestsGetPending :: Property |
| prop_WaitingRequestsGetPending = |
| forAllBlocked $ \state owner prio req -> |
| counterexample "After a not immediately fulfilled waiting request, owner\ |
| \ must have a pending request" |
| . S.member owner . getPendingOwners . fst |
| $ updateLocksWaiting prio owner req state |
| |
| -- | Verify that pending requests get fullfilled once all blockers release |
| -- their resources. |
| prop_PendingGetFulfilledEventually :: Property |
| prop_PendingGetFulfilledEventually = |
| forAllBlocked $ \state owner prio req -> |
| let oldpending = getPendingOwners state |
| (state', (resultBlockers, _)) = updateLocksWaiting prio owner req state |
| blockers = genericResult (const S.empty) id resultBlockers |
| state'' = S.foldl (\s a -> fst $ releaseResources a s) state' |
| $ S.union oldpending blockers |
| finallyOwned = listLocks owner $ getAllocation state'' |
| in counterexample "After all blockers and old pending owners give up their\ |
| \ resources, a pending request must be granted\ |
| \ automatically" |
| $ all (requestSucceeded finallyOwned) req |
| |
| -- | Verify that the owner of a pending request gets notified once all blockers |
| -- release their resources. |
| prop_PendingGetNotifiedEventually :: Property |
| prop_PendingGetNotifiedEventually = |
| forAllBlocked $ \state owner prio req -> |
| let oldpending = getPendingOwners state |
| (state', (resultBlockers, _)) = updateLocksWaiting prio owner req state |
| blockers = genericResult (const S.empty) id resultBlockers |
| releaseOneOwner (s, tonotify) o = |
| let (s', newnotify) = releaseResources o s |
| in (s', newnotify `S.union` tonotify) |
| (_, notified) = S.foldl releaseOneOwner (state', S.empty) |
| $ S.union oldpending blockers |
| in counterexample "After all blockers and old pending owners give up their\ |
| \ resources, a pending owner must be notified" |
| $ S.member owner notified |
| |
| -- | Verify that some progress is made after the direct blockers give up their |
| -- locks. Note that we cannot guarantee that the original requester gets its |
| -- request granted, as someone else might have a more important priority. |
| prop_Progress :: Property |
| prop_Progress = |
| forAllBlocked $ \state owner prio req -> |
| let (state', (resultBlockers, _)) = updateLocksWaiting prio owner req state |
| blockers = genericResult (const S.empty) id resultBlockers |
| releaseOneOwner (s, tonotify) o = |
| let (s', newnotify) = releaseResources o s |
| in (s', newnotify `S.union` tonotify) |
| (_, notified) = S.foldl releaseOneOwner (state', S.empty) blockers |
| in counterexample "Some progress must be made after all blockers release\ |
| \ their locks" |
| . not . S.null $ notified S.\\ blockers |
| |
| -- | Verify that the notifications send out are sound, i.e., upon notification |
| -- the requests actually are fulfilled. To be sure to have at least one |
| -- notification we, again, use the scenario that a request is blocked and then |
| -- all the blockers release their resources. |
| prop_ProgressSound :: Property |
| prop_ProgressSound = |
| forAllBlocked $ \state owner prio req -> |
| let (state', (resultBlockers, _)) = updateLocksWaiting prio owner req state |
| blockers = genericResult (const S.empty) id resultBlockers |
| releaseOneOwner (s, tonotify) o = |
| let (s', newnotify) = releaseResources o s |
| in (s', newnotify `S.union` tonotify) |
| (state'', notified) = S.foldl releaseOneOwner (state', S.empty) blockers |
| requestFulfilled o = |
| runListHead False |
| (\(_, _, r) -> |
| all (requestSucceeded . listLocks o $ getAllocation state'') r) |
| . S.toList . S.filter (\(_, b, _) -> b == o) |
| . getPendingRequests $ state' |
| in counterexample "If an owner gets notified, his request must be satisfied" |
| . all requestFulfilled . S.toList $ notified S.\\ blockers |
| |
| -- | Verify that all pending requests are valid and cannot be fulfilled in |
| -- the underlying lock allocation. |
| prop_PendingJustified :: Property |
| prop_PendingJustified = |
| forAll ((arbitrary :: Gen (LockWaiting TestLock TestOwner Integer)) |
| `suchThat` (not . S.null . getPendingRequests)) $ \state -> |
| let isJustified (_, b, req) = |
| genericResult (const False) (not . S.null) . snd |
| . L.updateLocks b req $ getAllocation state |
| in counterexample "Pending requests must be good and not fulfillable" |
| . all isJustified . S.toList $ getPendingRequests state |
| |
| -- | Verify that `updateLocks` is idempotent, except that in the repetition, |
| -- no waiters are notified. |
| prop_UpdateIdempotent :: Property |
| prop_UpdateIdempotent = |
| forAll (arbitrary :: Gen (LockWaiting TestLock TestOwner Integer)) $ \state -> |
| forAll (arbitrary :: Gen TestOwner) $ \owner -> |
| forAll (arbitrary :: Gen [LockRequest TestLock]) $ \req -> |
| let (state', (answer', _)) = updateLocks owner req state |
| (state'', (answer'', nfy)) = updateLocks owner req state' |
| in conjoin [ counterexample ("repeated updateLocks waiting gave different\ |
| \ answers: " ++ show answer' ++ " /= " |
| ++ show answer'') $ answer' == answer'' |
| , counterexample "updateLocks not idempotent" |
| $ extRepr state' == extRepr state'' |
| , counterexample ("notifications (" ++ show nfy ++ ") on replay") |
| $ S.null nfy |
| ] |
| |
| -- | Verify that extRepr . fromExtRepr = id for all valid extensional |
| -- representations. |
| prop_extReprPreserved :: Property |
| prop_extReprPreserved = |
| forAll (arbitrary :: Gen (LockWaiting TestLock TestOwner Integer)) $ \state -> |
| let rep = extRepr state |
| rep' = extRepr $ fromExtRepr rep |
| in counterexample "a lock waiting obtained from an extensional representation\ |
| \ must have the same extensional representation" |
| $ rep' == rep |
| |
| -- | Verify that any state is indistinguishable from its canonical version |
| -- (i.e., the one obtained from the extensional representation) with respect |
| -- to updateLocks. |
| prop_SimulateUpdateLocks :: Property |
| prop_SimulateUpdateLocks = |
| forAll (arbitrary :: Gen (LockWaiting TestLock TestOwner Integer)) $ \state -> |
| forAll (arbitrary :: Gen TestOwner) $ \owner -> |
| forAll (arbitrary :: Gen [LockRequest TestLock]) $ \req -> |
| let state' = fromExtRepr $ extRepr state |
| (finState, (result, notify)) = updateLocks owner req state |
| (finState', (result', notify')) = updateLocks owner req state' |
| in counterexample "extRepr-equal states must behave equal on updateLocks" |
| $ and [ result == result' |
| , notify == notify' |
| , extRepr finState == extRepr finState' |
| ] |
| -- | Verify that any state is indistinguishable from its canonical version |
| -- (i.e., the one obtained from the extensional representation) with respect |
| -- to updateLocksWaiting. |
| prop_SimulateUpdateLocksWaiting :: Property |
| prop_SimulateUpdateLocksWaiting = |
| forAll (arbitrary :: Gen (LockWaiting TestLock TestOwner Integer)) $ \state -> |
| forAll (arbitrary :: Gen TestOwner) $ \owner -> |
| forAll (arbitrary :: Gen Integer) $ \prio -> |
| forAll (arbitrary :: Gen [LockRequest TestLock]) $ \req -> |
| let state' = fromExtRepr $ extRepr state |
| (finState, (result, notify)) = updateLocksWaiting prio owner req state |
| (finState', (result', notify')) = updateLocksWaiting prio owner req state' |
| in counterexample "extRepr-equal states must behave equal on updateLocks" |
| $ and [ result == result' |
| , notify == notify' |
| , extRepr finState == extRepr finState' |
| ] |
| |
| -- | Verify that if a requestor has no pending requests, `safeUpdateWaiting` |
| -- conincides with `updateLocksWaiting`. |
| prop_SafeUpdateWaitingCorrect :: Property |
| prop_SafeUpdateWaitingCorrect = |
| forAll (arbitrary :: Gen TestOwner) $ \owner -> |
| forAll ((arbitrary :: Gen (LockWaiting TestLock TestOwner Integer)) |
| `suchThat` (not . hasPendingRequest owner)) $ \state -> |
| forAll (arbitrary :: Gen Integer) $ \prio -> |
| forAll (arbitrary :: Gen [LockRequest TestLock]) $ \req -> |
| let (state', answer') = updateLocksWaiting prio owner req state |
| (state'', answer'') = safeUpdateLocksWaiting prio owner req state |
| in conjoin [ counterexample ("safeUpdateLocksWaiting gave different answer: " |
| ++ show answer' ++ " /= " ++ show answer'') |
| $ answer' == answer'' |
| , counterexample ("safeUpdateLocksWaiting gave different states\ |
| \ after answer " ++ show answer' ++ ": " |
| ++ show (extRepr state') ++ " /= " |
| ++ show (extRepr state'')) |
| $ extRepr state' == extRepr state'' |
| ] |
| |
| -- | Verify that `safeUpdateLocksWaiting` is idempotent, that in the repetition |
| -- no notifications are done. |
| prop_SafeUpdateWaitingIdempotent :: Property |
| prop_SafeUpdateWaitingIdempotent = |
| forAll (arbitrary :: Gen (LockWaiting TestLock TestOwner Integer)) $ \state -> |
| forAll (arbitrary :: Gen TestOwner) $ \owner -> |
| forAll (arbitrary :: Gen Integer) $ \prio -> |
| forAll (arbitrary :: Gen [LockRequest TestLock]) $ \req -> |
| let (state', (answer', _)) = safeUpdateLocksWaiting prio owner req state |
| (state'', (answer'', nfy)) = safeUpdateLocksWaiting prio owner req state' |
| in conjoin [ counterexample ("repeated safeUpdateLocks waiting gave different\ |
| \ answers: " ++ show answer' ++ " /= " |
| ++ show answer'') $ answer' == answer'' |
| , counterexample "safeUpdateLocksWaiting not idempotent" |
| $ extRepr state' == extRepr state'' |
| , counterexample ("notifications (" ++ show nfy ++ ") on replay") |
| $ S.null nfy |
| ] |
| |
| -- | Verify that for LockWaiting we have readJSON . showJSON is extensionally |
| -- equivalent to Ok. |
| prop_ReadShow :: Property |
| prop_ReadShow = |
| forAll (arbitrary :: Gen (LockWaiting TestLock TestOwner Integer)) $ \state -> |
| (liftM extRepr . J.readJSON $ J.showJSON state) ==? (J.Ok $ extRepr state) |
| |
| -- | Verify that opportunistic union only increases the locks held. |
| prop_OpportunisticMonotone :: Property |
| prop_OpportunisticMonotone = |
| forAll (arbitrary :: Gen (LockWaiting TestLock TestOwner Integer)) $ \state -> |
| forAll (arbitrary :: Gen TestOwner) $ \a -> |
| forAll ((choose (1,3) >>= vector) :: Gen [(TestLock, L.OwnerState)]) $ \req -> |
| let (state', _) = opportunisticLockUnion a req state |
| oldOwned = listLocks a $ getAllocation state |
| oldLocks = M.keys oldOwned |
| newOwned = listLocks a $ getAllocation state' |
| in counterexample "Opportunistic union may only increase the set of locks\ |
| \ held" |
| . flip all oldLocks $ \lock -> |
| M.lookup lock newOwned >= M.lookup lock oldOwned |
| |
| -- | Verify the result list of the opportunistic union: if a lock is not in |
| -- the result that, than its state has not changed, and if it is, it is as |
| -- requested. The latter property is tested in that liberal way, so that we |
| -- really can take arbitrary requests, including those that require both, shared |
| -- and exlusive state for the same lock. |
| prop_OpportunisticAnswer :: Property |
| prop_OpportunisticAnswer = |
| forAll (arbitrary :: Gen (LockWaiting TestLock TestOwner Integer)) $ \state -> |
| forAll (arbitrary :: Gen TestOwner) $ \a -> |
| forAll ((choose (1,3) >>= vector) :: Gen [(TestLock, L.OwnerState)]) $ \req -> |
| let (state', (result, _)) = opportunisticLockUnion a req state |
| oldOwned = listLocks a $ getAllocation state |
| newOwned = listLocks a $ getAllocation state' |
| involvedLocks = M.keys oldOwned ++ map fst req |
| in conjoin [ counterexample ("Locks not in the answer set " ++ show result |
| ++ " may not be changed, but found " |
| ++ show state') |
| . flip all involvedLocks $ \lock -> |
| (lock `elem` result) |
| || (M.lookup lock oldOwned == M.lookup lock newOwned) |
| , counterexample ("Locks not in the answer set " ++ show result |
| ++ " must be as requested, but found " |
| ++ show state') |
| . flip all involvedLocks $ \lock -> |
| notElem lock result |
| || maybe False (flip elem req . (,) lock) |
| (M.lookup lock newOwned) |
| ] |
| |
| |
| testSuite "Locking/Waiting" |
| [ 'prop_NoActionWithPendingRequests |
| , 'prop_WaitingRequestsGetPending |
| , 'prop_PendingGetFulfilledEventually |
| , 'prop_PendingGetNotifiedEventually |
| , 'prop_Progress |
| , 'prop_ProgressSound |
| , 'prop_PendingJustified |
| , 'prop_extReprPreserved |
| , 'prop_UpdateIdempotent |
| , 'prop_SimulateUpdateLocks |
| , 'prop_SimulateUpdateLocksWaiting |
| , 'prop_ReadShow |
| , 'prop_SafeUpdateWaitingCorrect |
| , 'prop_SafeUpdateWaitingIdempotent |
| , 'prop_OpportunisticMonotone |
| , 'prop_OpportunisticAnswer |
| ] |
