Statistics
| Branch: | Tag: | Revision:

root / test / hs / Test / Ganeti / Locking / Allocation.hs @ 9bf17b50

History | View | Annotate | Download (7.1 kB)

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.Foldable as F
33
import qualified Data.Map as M
34
import qualified Data.Set as S
35

    
36
import Test.QuickCheck
37

    
38
import Test.Ganeti.TestCommon
39
import Test.Ganeti.TestHelper
40

    
41
import Ganeti.BasicTypes
42
import Ganeti.Locking.Allocation
43
import Ganeti.Locking.Types
44

    
45
{-
46

    
47
Ganeti.Locking.Allocation is polymorphic in the types of locks
48
and lock owners. So we can use much simpler types here than Ganeti's
49
real locks and lock owners, knowning at polymorphic functions cannot
50
exploit the simplicity of the types they're deling with.
51

    
52
-}
53

    
54
data TestOwner = TestOwner Int deriving (Ord, Eq, Show)
55

    
56
instance Arbitrary TestOwner where
57
  arbitrary = TestOwner <$> choose (0, 2)
58

    
59
data TestLock = TestBigLock
60
              | TestCollectionLockA
61
              | TestLockA Int
62
              | TestCollectionLockB
63
              | TestLockB Int
64
              deriving (Ord, Eq, Show)
65

    
66
instance Arbitrary TestLock where
67
  arbitrary =  frequency [ (1, elements [ TestBigLock
68
                                        , TestCollectionLockA
69
                                        , TestCollectionLockB
70
                                        ])
71
                         , (2, TestLockA <$> choose (0, 2))
72
                         , (2, TestLockB <$> choose (0, 2))
73
                         ]
74

    
75
instance Lock TestLock where
76
  lockImplications (TestLockA _) = [TestCollectionLockA, TestBigLock]
77
  lockImplications (TestLockB _) = [TestCollectionLockB, TestBigLock]
78
  lockImplications TestBigLock = []
79
  lockImplications _ = [TestBigLock]
80

    
81
{-
82

    
83
All states of a  LockAllocation can be obtained by starting from the
84
empty allocation, and sequentially requesting (successfully or not)
85
lock updates. So we first define what arbitrary updates sequences are.
86

    
87
-}
88

    
89
instance Arbitrary OwnerState where
90
  arbitrary = elements [OwnShared, OwnExclusive]
91

    
92
instance Arbitrary a => Arbitrary (LockRequest a) where
93
  arbitrary = LockRequest <$> arbitrary <*> genMaybe arbitrary
94

    
95
data UpdateRequest a b = UpdateRequest a [LockRequest b] deriving Show
96

    
97
instance (Arbitrary a, Arbitrary b) => Arbitrary (UpdateRequest a b) where
98
  arbitrary = UpdateRequest <$> arbitrary <*> arbitrary
99

    
100
-- | Fold a sequence of update requests; all allocations can be obtained in
101
-- this way, starting from the empty allocation.
102
foldUpdates :: (Lock a, Ord b, Show b)
103
            => LockAllocation a b -> [UpdateRequest b a] -> LockAllocation a b
104
foldUpdates = foldl (\s (UpdateRequest owner updates) ->
105
                      fst $ updateLocks owner updates s)
106

    
107
instance (Arbitrary a, Lock a, Arbitrary b, Ord b, Show b)
108
          => Arbitrary (LockAllocation a b) where
109
  arbitrary = foldUpdates emptyAllocation <$> arbitrary
110

    
111
-- | Basic property of locking: the exclusive locks of one user
112
-- are disjoint from any locks of any other user.
113
prop_LocksDisjoint :: Property
114
prop_LocksDisjoint =
115
  forAll (arbitrary :: Gen (LockAllocation TestLock TestOwner)) $ \state ->
116
  forAll (arbitrary :: Gen TestOwner) $ \a ->
117
  forAll (arbitrary `suchThat` (/= a)) $ \b ->
118
  let aExclusive = M.keysSet . M.filter (== OwnExclusive) $ listLocks  a state
119
      bAll = M.keysSet $ listLocks b state
120
  in printTestCase
121
     (show a ++ "'s exclusive lock" ++ " is not respected by " ++ show b)
122
     (S.null $ S.intersection aExclusive bAll)
123

    
124
-- | Verify that locks can only be modified by updates of the owner.
125
prop_LocksStable :: Property
126
prop_LocksStable =
127
  forAll (arbitrary :: Gen (LockAllocation TestLock TestOwner)) $ \state ->
128
  forAll (arbitrary :: Gen TestOwner) $ \a ->
129
  forAll (arbitrary `suchThat` (/= a)) $ \b ->
130
  forAll (arbitrary :: Gen [LockRequest TestLock]) $ \request ->
131
  let (state', _) = updateLocks b request state
132
  in (listLocks a state ==? listLocks a state')
133

    
134
-- | Verify that a given request is statisfied in list of owned locks
135
requestSucceeded :: Ord a => M.Map a  OwnerState -> LockRequest a -> Bool
136
requestSucceeded owned (LockRequest lock status) = M.lookup lock owned == status
137

    
138
-- | Verify that lock updates are atomic, i.e., either we get all the required
139
-- locks, or the state is completely unchanged.
140
prop_LockupdateAtomic :: Property
141
prop_LockupdateAtomic =
142
  forAll (arbitrary :: Gen (LockAllocation TestLock TestOwner)) $ \state ->
143
  forAll (arbitrary :: Gen TestOwner) $ \a ->
144
  forAll (arbitrary :: Gen [LockRequest TestLock]) $ \request ->
145
  let (state', result) = updateLocks a request state
146
  in if result == Ok S.empty
147
       then printTestCase
148
            ("Update succeeded, but in final state " ++ show state'
149
              ++ "not all locks are as requested")
150
            $ let owned = listLocks a state'
151
              in all (requestSucceeded owned) request
152
       else printTestCase
153
            ("Update failed, but state changed to " ++ show state')
154
            (state == state')
155

    
156
-- | Verify that releasing a lock always succeeds.
157
prop_LockReleaseSucceeds :: Property
158
prop_LockReleaseSucceeds =
159
  forAll (arbitrary :: Gen (LockAllocation TestLock TestOwner)) $ \state ->
160
  forAll (arbitrary :: Gen TestOwner) $ \a ->
161
  forAll (arbitrary :: Gen TestLock) $ \lock ->
162
  let (_, result) = updateLocks a [requestRelease lock] state
163
  in printTestCase
164
     ("Releasing a lock has to suceed uncondiationally, but got "
165
       ++ show result)
166
     (isOk result)
167

    
168
-- | Verify the property that only the blocking owners prevent
169
-- lock allocation. We deliberatly go for the expensive variant
170
-- restraining by suchThat, as otherwise the number of cases actually
171
-- covered is too small.
172
prop_BlockSufficient :: Property
173
prop_BlockSufficient =
174
  forAll (arbitrary :: Gen TestOwner) $ \a ->
175
  forAll (arbitrary :: Gen TestLock) $ \lock ->
176
  forAll (elements [ [requestShared lock]
177
                   , [requestExclusive lock]]) $ \request ->
178
  forAll ((arbitrary :: Gen (LockAllocation TestLock TestOwner))
179
           `suchThat` (genericResult (const False) (not . S.null)
180
                        . snd . updateLocks a request)) $ \state ->
181
  let (_, result) = updateLocks a request state
182
      blockedOn = genericResult (const S.empty) id result
183
  in  printTestCase "After all blockers release, a request must succeed"
184
      . isOk . snd . updateLocks a request $ F.foldl freeLocks state blockedOn
185

    
186
testSuite "Locking/Allocation"
187
 [ 'prop_LocksDisjoint
188
 , 'prop_LocksStable
189
 , 'prop_LockupdateAtomic
190
 , 'prop_LockReleaseSucceeds
191
 , 'prop_BlockSufficient
192
 ]