|
1 |
{-# LANGUAGE TemplateHaskell #-}
|
|
2 |
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
3 |
|
|
4 |
{-| Tests for lock allocation.
|
|
5 |
|
|
6 |
-}
|
|
7 |
|
|
8 |
{-
|
|
9 |
|
|
10 |
Copyright (C) 2014 Google Inc.
|
|
11 |
|
|
12 |
This program is free software; you can redistribute it and/or modify
|
|
13 |
it under the terms of the GNU General Public License as published by
|
|
14 |
the Free Software Foundation; either version 2 of the License, or
|
|
15 |
(at your option) any later version.
|
|
16 |
|
|
17 |
This program is distributed in the hope that it will be useful, but
|
|
18 |
WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
19 |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
20 |
General Public License for more details.
|
|
21 |
|
|
22 |
You should have received a copy of the GNU General Public License
|
|
23 |
along with this program; if not, write to the Free Software
|
|
24 |
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
|
|
25 |
02110-1301, USA.
|
|
26 |
|
|
27 |
-}
|
|
28 |
|
|
29 |
module Test.Ganeti.Locking.Allocation (testLocking_Allocation) where
|
|
30 |
|
|
31 |
import Control.Applicative
|
|
32 |
import qualified Data.Map as M
|
|
33 |
import qualified Data.Set as S
|
|
34 |
|
|
35 |
import Test.QuickCheck
|
|
36 |
|
|
37 |
import Test.Ganeti.TestHelper
|
|
38 |
|
|
39 |
import Ganeti.Locking.Allocation
|
|
40 |
|
|
41 |
{-
|
|
42 |
|
|
43 |
Ganeti.Locking.Allocation is polymorphic in the types of locks
|
|
44 |
and lock owners. So we can use much simpler types here than Ganeti's
|
|
45 |
real locks and lock owners, knowning at polymorphic functions cannot
|
|
46 |
exploit the simplicity of the types they're deling with.
|
|
47 |
|
|
48 |
-}
|
|
49 |
|
|
50 |
data TestOwner = TestOwner Int deriving (Ord, Eq, Show)
|
|
51 |
|
|
52 |
instance Arbitrary TestOwner where
|
|
53 |
arbitrary = TestOwner <$> choose (0, 7)
|
|
54 |
|
|
55 |
data TestLock = TestLock Int deriving (Ord, Eq, Show)
|
|
56 |
|
|
57 |
instance Arbitrary TestLock where
|
|
58 |
arbitrary = TestLock <$> choose (0, 7)
|
|
59 |
|
|
60 |
|
|
61 |
{-
|
|
62 |
|
|
63 |
All states of a LockAllocation can be obtained by starting from the
|
|
64 |
empty allocation, and sequentially requesting (successfully or not)
|
|
65 |
lock updates. So we first define what arbitrary updates sequences are.
|
|
66 |
|
|
67 |
-}
|
|
68 |
|
|
69 |
instance Arbitrary OwnerState where
|
|
70 |
arbitrary = elements [OwnShared, OwnExclusive]
|
|
71 |
|
|
72 |
instance Arbitrary a => Arbitrary (LockRequest a) where
|
|
73 |
arbitrary = LockRequest <$> arbitrary <*> genMaybe arbitrary
|
|
74 |
|
|
75 |
data UpdateRequest a b = UpdateRequest a [LockRequest b] deriving Show
|
|
76 |
|
|
77 |
instance (Arbitrary a, Arbitrary b) => Arbitrary (UpdateRequest a b) where
|
|
78 |
arbitrary = UpdateRequest <$> arbitrary <*> arbitrary
|
|
79 |
|
|
80 |
-- | Fold a sequence of update requests; all allocationscan be obtained in
|
|
81 |
-- this way, starting from the empty allocation.
|
|
82 |
foldUpdates :: (Ord a, Ord b, Show b)
|
|
83 |
=> LockAllocation b a -> [UpdateRequest a b] -> LockAllocation b a
|
|
84 |
foldUpdates = foldl (\s (UpdateRequest owner updates) ->
|
|
85 |
fst $ updateLocks owner updates s)
|
|
86 |
|
|
87 |
instance (Arbitrary a, Arbitrary b, Ord a, Ord b, Show a, Show b)
|
|
88 |
=> Arbitrary (LockAllocation a b) where
|
|
89 |
arbitrary = foldUpdates emptyAllocation <$> arbitrary
|
|
90 |
|
|
91 |
-- | Basic property of locking: the exclusive locks of one user
|
|
92 |
-- are disjoint from any locks of any other user.
|
|
93 |
prop_LocksDisjoint :: Property
|
|
94 |
prop_LocksDisjoint =
|
|
95 |
forAll (arbitrary :: Gen (LockAllocation TestLock TestOwner)) $ \state ->
|
|
96 |
forAll (arbitrary :: Gen TestOwner) $ \a ->
|
|
97 |
forAll (arbitrary `suchThat` (/= a)) $ \b ->
|
|
98 |
let aExclusive = M.keysSet . M.filter (== OwnExclusive) $ listLocks a state
|
|
99 |
bAll = M.keysSet $ listLocks b state
|
|
100 |
in printTestCase
|
|
101 |
(show a ++ "'s exclusive lock" ++ " is not respected by " ++ show b)
|
|
102 |
(S.null $ S.intersection aExclusive bAll)
|
|
103 |
|
|
104 |
testSuite "Locking/Allocation"
|
|
105 |
[ 'prop_LocksDisjoint
|
|
106 |
]
|