Statistics
| Branch: | Tag: | Revision:

root / test / hs / Test / Ganeti / Locking / Allocation.hs @ a9c3ba29

History | View | Annotate | Download (5.4 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.Map as M
33
import qualified Data.Set as S
34

    
35
import Test.QuickCheck
36

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

    
40
import Ganeti.BasicTypes
41
import Ganeti.Locking.Allocation
42

    
43
{-
44

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

    
50
-}
51

    
52
data TestOwner = TestOwner Int deriving (Ord, Eq, Show)
53

    
54
instance Arbitrary TestOwner where
55
  arbitrary = TestOwner <$> choose (0, 7)
56

    
57
data TestLock = TestLock Int deriving (Ord, Eq, Show)
58

    
59
instance Arbitrary TestLock where
60
  arbitrary = TestLock <$> choose (0, 7)
61

    
62

    
63
{-
64

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

    
69
-}
70

    
71
instance Arbitrary OwnerState where
72
  arbitrary = elements [OwnShared, OwnExclusive]
73

    
74
instance Arbitrary a => Arbitrary (LockRequest a) where
75
  arbitrary = LockRequest <$> arbitrary <*> genMaybe arbitrary
76

    
77
data UpdateRequest a b = UpdateRequest a [LockRequest b] deriving Show
78

    
79
instance (Arbitrary a, Arbitrary b) => Arbitrary (UpdateRequest a b) where
80
  arbitrary = UpdateRequest <$> arbitrary <*> arbitrary
81

    
82
-- | Fold a sequence of update requests; all allocationscan be obtained in
83
-- this way, starting from the empty allocation.
84
foldUpdates :: (Ord a, Ord b, Show b)
85
            => LockAllocation b a -> [UpdateRequest a b] -> LockAllocation b a
86
foldUpdates = foldl (\s (UpdateRequest owner updates) ->
87
                      fst $ updateLocks owner updates s)
88

    
89
instance (Arbitrary a, Arbitrary b, Ord a, Ord b, Show a, Show b)
90
          => Arbitrary (LockAllocation a b) where
91
  arbitrary = foldUpdates emptyAllocation <$> arbitrary
92

    
93
-- | Basic property of locking: the exclusive locks of one user
94
-- are disjoint from any locks of any other user.
95
prop_LocksDisjoint :: Property
96
prop_LocksDisjoint =
97
  forAll (arbitrary :: Gen (LockAllocation TestLock TestOwner)) $ \state ->
98
  forAll (arbitrary :: Gen TestOwner) $ \a ->
99
  forAll (arbitrary `suchThat` (/= a)) $ \b ->
100
  let aExclusive = M.keysSet . M.filter (== OwnExclusive) $ listLocks  a state
101
      bAll = M.keysSet $ listLocks b state
102
  in printTestCase
103
     (show a ++ "'s exclusive lock" ++ " is not respected by " ++ show b)
104
     (S.null $ S.intersection aExclusive bAll)
105

    
106
-- | Verify that locks can only be modified by updates of the owner.
107
prop_LocksStable :: Property
108
prop_LocksStable =
109
  forAll (arbitrary :: Gen (LockAllocation TestLock TestOwner)) $ \state ->
110
  forAll (arbitrary :: Gen TestOwner) $ \a ->
111
  forAll (arbitrary `suchThat` (/= a)) $ \b ->
112
  forAll (arbitrary :: Gen [LockRequest TestLock]) $ \request ->
113
  let (state', _) = updateLocks b request state
114
  in (listLocks a state ==? listLocks a state')
115

    
116
-- | Verify that a given request is statisfied in list of owned locks
117
requestSucceeded :: Ord a => M.Map a  OwnerState -> LockRequest a -> Bool
118
requestSucceeded owned (LockRequest lock status) = M.lookup lock owned == status
119

    
120
-- | Verify that lock updates are atomic, i.e., either we get all the required
121
-- locks, or the state is completely unchanged.
122
prop_LockupdateAtomic :: Property
123
prop_LockupdateAtomic =
124
  forAll (arbitrary :: Gen (LockAllocation TestLock TestOwner)) $ \state ->
125
  forAll (arbitrary :: Gen TestOwner) $ \a ->
126
  forAll (arbitrary :: Gen [LockRequest TestLock]) $ \request ->
127
  let (state', result) = updateLocks a request state
128
  in if result == Ok S.empty
129
       then printTestCase
130
            ("Update succeeded, but in final state " ++ show state'
131
              ++ "not all locks are as requested")
132
            $ let owned = listLocks a state'
133
              in all (requestSucceeded owned) request
134
       else printTestCase
135
            ("Update failed, but state changed to " ++ show state')
136
            (state == state')
137

    
138
-- | Verify that releasing a lock always succeeds.
139
prop_LockReleaseSucceeds :: Property
140
prop_LockReleaseSucceeds =
141
  forAll (arbitrary :: Gen (LockAllocation TestLock TestOwner)) $ \state ->
142
  forAll (arbitrary :: Gen TestOwner) $ \a ->
143
  forAll (arbitrary :: Gen TestLock) $ \lock ->
144
  let (_, result) = updateLocks a [requestRelease lock] state
145
  in printTestCase
146
     ("Releasing a lock has to suceed uncondiationally, but got "
147
       ++ show result)
148
     (isOk result)
149

    
150
testSuite "Locking/Allocation"
151
 [ 'prop_LocksDisjoint
152
 , 'prop_LocksStable
153
 , 'prop_LockupdateAtomic
154
 , 'prop_LockReleaseSucceeds
155
 ]