Revision 381889dc
b/src/Ganeti/Locking/Allocation.hs | ||
---|---|---|
38 | 38 |
|
39 | 39 |
import Control.Arrow (second, (***)) |
40 | 40 |
import Control.Monad |
41 |
import Data.Foldable (for_) |
|
41 |
import Data.Foldable (for_, find)
|
|
42 | 42 |
import qualified Data.Map as M |
43 | 43 |
import Data.Maybe (fromMaybe) |
44 | 44 |
import qualified Data.Set as S |
45 | 45 |
|
46 | 46 |
import Ganeti.BasicTypes |
47 |
import Ganeti.Locking.Types |
|
47 | 48 |
|
48 | 49 |
{- |
49 | 50 |
|
... | ... | |
55 | 56 |
|
56 | 57 |
-} |
57 | 58 |
|
58 |
-- | The state of a lock that is taken. |
|
59 |
data AllocationState a = Exclusive a | Shared (S.Set a) deriving (Eq, Show) |
|
60 |
|
|
61 | 59 |
-- | Data type describing the way a lock can be owned. |
62 | 60 |
data OwnerState = OwnShared | OwnExclusive deriving (Ord, Eq, Show) |
63 | 61 |
|
62 |
-- | Type describing indirect ownership on a lock. We keep the set |
|
63 |
-- of all (lock, owner)-pairs for locks that are implied in the given |
|
64 |
-- lock, annotated with the type of ownership (shared or exclusive). |
|
65 |
type IndirectOwners a b = M.Map (a, b) OwnerState |
|
66 |
|
|
67 |
-- | The state of a lock that is taken. Besides the state of the lock |
|
68 |
-- itself, we also keep track of all other lock allocation that affect |
|
69 |
-- the given lock by means of implication. |
|
70 |
data AllocationState a b = Exclusive b (IndirectOwners a b) |
|
71 |
| Shared (S.Set b) (IndirectOwners a b) |
|
72 |
deriving (Eq, Show) |
|
73 |
|
|
74 |
-- | Compute the set of indirect owners from the information about |
|
75 |
-- indirect ownership. |
|
76 |
indirectOwners :: (Ord a, Ord b) => M.Map (a, b) OwnerState -> S.Set b |
|
77 |
indirectOwners = S.map snd . M.keysSet |
|
78 |
|
|
79 |
-- | Compute the (zero or one-elment) set of exclusive indirect owners. |
|
80 |
indirectExclusives :: (Ord a, Ord b) => M.Map (a, b) OwnerState -> S.Set b |
|
81 |
indirectExclusives = indirectOwners . M.filter (== OwnExclusive) |
|
82 |
|
|
64 | 83 |
{-| Representation of a Lock allocation |
65 | 84 |
|
66 | 85 |
To keep queries for locks efficient, we keep two |
... | ... | |
75 | 94 |
-} |
76 | 95 |
|
77 | 96 |
data LockAllocation a b = |
78 |
LockAllocation { laLocks :: M.Map a (AllocationState b) |
|
97 |
LockAllocation { laLocks :: M.Map a (AllocationState a b)
|
|
79 | 98 |
, laOwned :: M.Map b (M.Map a OwnerState) |
80 | 99 |
} |
81 | 100 |
deriving (Eq, Show) |
... | ... | |
114 | 133 |
requestRelease lock = LockRequest { lockAffected = lock |
115 | 134 |
, lockRequestType = Nothing } |
116 | 135 |
|
136 |
-- | Update the Allocation state of a lock according to a given |
|
137 |
-- function. |
|
138 |
updateAllocState :: (Ord a, Ord b) |
|
139 |
=> (Maybe (AllocationState a b) -> AllocationState a b) |
|
140 |
-> LockAllocation a b -> a -> LockAllocation a b |
|
141 |
updateAllocState f state lock = |
|
142 |
let locks' = M.alter (find (/= Shared S.empty M.empty) . Just . f) |
|
143 |
lock (laLocks state) |
|
144 |
in state { laLocks = locks' } |
|
145 |
|
|
117 | 146 |
-- | Internal function to update the state according to a single |
118 | 147 |
-- lock request, assuming all prerequisites are met. |
119 | 148 |
updateLock :: (Ord a, Ord b) |
120 | 149 |
=> b |
121 | 150 |
-> LockAllocation a b -> LockRequest a -> LockAllocation a b |
122 | 151 |
updateLock owner state (LockRequest lock (Just OwnExclusive)) = |
123 |
let locks' = M.insert lock (Exclusive owner) $ laLocks state |
|
152 |
let locks = laLocks state |
|
153 |
lockstate' = case M.lookup lock locks of |
|
154 |
Just (Exclusive _ i) -> Exclusive owner i |
|
155 |
Just (Shared _ i) -> Exclusive owner i |
|
156 |
Nothing -> Exclusive owner M.empty |
|
157 |
locks' = M.insert lock lockstate' locks |
|
124 | 158 |
ownersLocks' = M.insert lock OwnExclusive $ listLocks owner state |
125 | 159 |
owned' = M.insert owner ownersLocks' $ laOwned state |
126 | 160 |
in state { laLocks = locks', laOwned = owned' } |
... | ... | |
129 | 163 |
owned' = M.insert owner ownersLocks' $ laOwned state |
130 | 164 |
locks = laLocks state |
131 | 165 |
lockState' = case M.lookup lock locks of |
132 |
Just (Shared s) -> Shared (S.insert owner s) |
|
133 |
_ -> Shared $ S.singleton owner |
|
166 |
Just (Exclusive _ i) -> Shared (S.singleton owner) i |
|
167 |
Just (Shared s i) -> Shared (S.insert owner s) i |
|
168 |
_ -> Shared (S.singleton owner) M.empty |
|
134 | 169 |
locks' = M.insert lock lockState' locks |
135 | 170 |
in state { laLocks = locks', laOwned = owned' } |
136 | 171 |
updateLock owner state (LockRequest lock Nothing) = |
... | ... | |
139 | 174 |
owned' = if M.null ownersLocks' |
140 | 175 |
then M.delete owner owned |
141 | 176 |
else M.insert owner ownersLocks' owned |
142 |
locks = laLocks state |
|
143 |
lockRemoved = M.delete lock locks |
|
144 |
locks' = case M.lookup lock locks of |
|
145 |
Nothing -> locks |
|
146 |
Just (Exclusive x) -> |
|
147 |
if x == owner then lockRemoved else locks |
|
148 |
Just (Shared s) |
|
149 |
-> let s' = S.delete owner s |
|
150 |
in if S.null s' |
|
151 |
then lockRemoved |
|
152 |
else M.insert lock (Shared s') locks |
|
153 |
in state { laLocks = locks', laOwned = owned' } |
|
177 |
update (Just (Exclusive x i)) = if x == owner |
|
178 |
then Shared S.empty i |
|
179 |
else Exclusive x i |
|
180 |
update (Just (Shared s i)) = Shared (S.delete owner s) i |
|
181 |
update Nothing = Shared S.empty M.empty |
|
182 |
in updateAllocState update (state { laOwned = owned' }) lock |
|
183 |
|
|
184 |
-- | Update the set of indirect ownerships of a lock by the given function. |
|
185 |
updateIndirectSet :: (Ord a, Ord b) |
|
186 |
=> (IndirectOwners a b -> IndirectOwners a b) |
|
187 |
-> LockAllocation a b -> a -> LockAllocation a b |
|
188 |
updateIndirectSet f = |
|
189 |
let update (Just (Exclusive x i)) = Exclusive x (f i) |
|
190 |
update (Just (Shared s i)) = Shared s (f i) |
|
191 |
update Nothing = Shared S.empty (f M.empty) |
|
192 |
in updateAllocState update |
|
193 |
|
|
194 |
-- | Update all indirect onwerships of a given lock. |
|
195 |
updateIndirects :: (Lock a, Ord b) |
|
196 |
=> b |
|
197 |
-> LockAllocation a b -> LockRequest a -> LockAllocation a b |
|
198 |
updateIndirects owner state req = |
|
199 |
let lock = lockAffected req |
|
200 |
fn = case lockRequestType req of |
|
201 |
Nothing -> M.delete (lock, owner) |
|
202 |
Just tp -> M.insert (lock, owner) tp |
|
203 |
in foldl (updateIndirectSet fn) state $ lockImplications lock |
|
154 | 204 |
|
155 | 205 |
-- | Update the locks of an owner according to the given request. Return |
156 | 206 |
-- the pair of the new state and the result of the operation, which is the |
157 | 207 |
-- the set of owners on which the operation was blocked on. so an empty set is |
158 | 208 |
-- success, and the state is updated if, and only if, the returned set is emtpy. |
159 | 209 |
-- In that way, it can be used in atomicModifyIORef. |
160 |
updateLocks :: (Ord a, Show a, Ord b)
|
|
161 |
=> b
|
|
162 |
-> [LockRequest a]
|
|
163 |
-> LockAllocation a b -> (LockAllocation a b, Result (S.Set b))
|
|
210 |
updateLocks :: (Lock a, Ord b)
|
|
211 |
=> b |
|
212 |
-> [LockRequest a] |
|
213 |
-> LockAllocation a b -> (LockAllocation a b, Result (S.Set b)) |
|
164 | 214 |
updateLocks owner reqs state = genericResult ((,) state . Bad) (second Ok) $ do |
165 | 215 |
runListHead (return ()) |
166 | 216 |
(fail . (++) "Inconsitent requests for lock " . show) $ do |
... | ... | |
188 | 238 |
let blockedOn (LockRequest _ Nothing) = S.empty |
189 | 239 |
blockedOn (LockRequest lock (Just OwnExclusive)) = |
190 | 240 |
case M.lookup lock (laLocks state) of |
191 |
Just (Exclusive x) -> S.singleton x |
|
192 |
Just (Shared xs) -> xs |
|
241 |
Just (Exclusive x i) -> |
|
242 |
S.singleton x `S.union` indirectOwners i |
|
243 |
Just (Shared xs i) -> |
|
244 |
xs `S.union` indirectOwners i |
|
193 | 245 |
_ -> S.empty |
194 | 246 |
blockedOn (LockRequest lock (Just OwnShared)) = |
195 | 247 |
case M.lookup lock (laLocks state) of |
196 |
Just (Exclusive x) -> S.singleton x |
|
248 |
Just (Exclusive x i) -> |
|
249 |
S.singleton x `S.union` indirectExclusives i |
|
250 |
Just (Shared _ i) -> indirectExclusives i |
|
251 |
_ -> S.empty |
|
252 |
let indirectBlocked Nothing _ = S.empty |
|
253 |
indirectBlocked (Just OwnShared) lock = |
|
254 |
case M.lookup lock (laLocks state) of |
|
255 |
Just (Exclusive x _) -> S.singleton x |
|
256 |
_ -> S.empty |
|
257 |
indirectBlocked (Just OwnExclusive) lock = |
|
258 |
case M.lookup lock (laLocks state) of |
|
259 |
Just (Exclusive x _) -> S.singleton x |
|
260 |
Just (Shared xs _) -> xs |
|
197 | 261 |
_ -> S.empty |
198 |
let blocked = S.delete owner . S.unions $ map blockedOn reqs |
|
262 |
let direct = S.unions $ map blockedOn reqs |
|
263 |
indirect = reqs >>= \req -> |
|
264 |
map (indirectBlocked (lockRequestType req)) |
|
265 |
. lockImplications $ lockAffected req |
|
266 |
let blocked = S.delete owner . S.unions $ direct:indirect |
|
199 | 267 |
let state' = foldl (updateLock owner) state reqs |
200 |
return (if S.null blocked then state' else state, blocked) |
|
268 |
state'' = foldl (updateIndirects owner) state' reqs |
|
269 |
return (if S.null blocked then state'' else state, blocked) |
|
201 | 270 |
|
202 | 271 |
-- | Compute the state after an onwer releases all its locks. |
203 | 272 |
freeLocks :: (Lock a, Ord b) => LockAllocation a b -> b -> LockAllocation a b |
Also available in: Unified diff