Waiting.hs 9.33 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

{-| Tests for lock waiting structure.

-}

{-

Copyright (C) 2014 Google Inc.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.

-}

module Test.Ganeti.Locking.Waiting (testLocking_Waiting) where

31
32
import Control.Applicative ((<$>), (<*>), liftA2)
import qualified Data.Map as M
33
34
35
36
37
import qualified Data.Set as S

import Test.QuickCheck

import Test.Ganeti.TestHelper
38
import Test.Ganeti.Locking.Allocation (TestLock, TestOwner, requestSucceeded)
39

40
import Ganeti.BasicTypes (isBad, genericResult, runListHead)
41
import Ganeti.Locking.Allocation (LockRequest, listLocks)
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
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]
64
                         | RemovePending b
65
66
67
68
69
                         deriving Show

instance (Arbitrary a, Arbitrary b, Arbitrary c)
         => Arbitrary (UpdateRequest a b c) where
  arbitrary =
70
71
    frequency [ (2, Update <$> arbitrary <*> (choose (1, 4) >>= vector))
              , (4, UpdateWaiting <$> arbitrary <*> arbitrary
72
                                  <*> (choose (1, 4) >>= vector))
73
              , (1, RemovePending <$> arbitrary)
74
75
76
77
78
79
80
81
              ]

-- | 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
82
asWaitingTrans state (RemovePending owner) = removePendingRequest owner state
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108


-- | 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 ->
  printTestCase "Owners with pending requests may not update locks"
  . all (isBad . fst . snd)
  $ [updateLocks, updateLocksWaiting prio] <*> [a] <*> [req] <*> [state]

109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
-- | 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 ->
  printTestCase "After a not immediately fulfilled waiting request, owner\
                \ must have a pending request"
  . S.member owner . getPendingOwners . fst
  $ updateLocksWaiting prio owner req state

145
146
147
148
149
150
151
152
153
154
155
156
157
158
-- | 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 printTestCase "After all blockers and old pending owners give up their\
                   \ resources, a pending request must be granted automatically"
     $ all (requestSucceeded finallyOwned) req
159

160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
-- | 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 printTestCase "After all blockers and old pending owners give up their\
                   \ resources, a pending owner must be notified"
     $ S.member owner notified

177
178
179
180
181
182
183
184
185
186
187
188
189
190
-- | 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 printTestCase "Some progress must be made after all blockers release\
                   \ their locks"
191
     . not . S.null $ notified S.\\ blockers
192

193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
-- | 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 printTestCase "If an owner gets notified, his request must be satisfied"
     . all requestFulfilled . S.toList $ notified S.\\ blockers

215
216
testSuite "Locking/Waiting"
 [ 'prop_NoActionWithPendingRequests
217
 , 'prop_WaitingRequestsGetPending
218
 , 'prop_PendingGetFulfilledEventually
219
 , 'prop_PendingGetNotifiedEventually
220
 , 'prop_Progress
221
 , 'prop_ProgressSound
222
 ]