Merge branch 'stable-2.16' into stable-2.17
[ganeti-github.git] / src / Ganeti / Locking / Allocation.hs
1 {-| Implementation of lock allocation.
2
3 -}
4
5 {-
6
7 Copyright (C) 2014 Google Inc.
8 All rights reserved.
9
10 Redistribution and use in source and binary forms, with or without
11 modification, are permitted provided that the following conditions are
12 met:
13
14 1. Redistributions of source code must retain the above copyright notice,
15 this list of conditions and the following disclaimer.
16
17 2. Redistributions in binary form must reproduce the above copyright
18 notice, this list of conditions and the following disclaimer in the
19 documentation and/or other materials provided with the distribution.
20
21 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
22 IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
23 TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
24 PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
25 CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
26 EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
27 PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28 PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29 LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32
33 -}
34
35 module Ganeti.Locking.Allocation
36 ( LockAllocation
37 , emptyAllocation
38 , OwnerState(..)
39 , lockOwners
40 , listLocks
41 , listAllLocks
42 , listAllLocksOwners
43 , holdsLock
44 , LockRequest(..)
45 , requestExclusive
46 , requestShared
47 , requestRelease
48 , updateLocks
49 , freeLocks
50 ) where
51
52 import Prelude ()
53 import Ganeti.Prelude
54
55 import Control.Applicative (liftA2)
56 import Control.Arrow (second, (***))
57 import Control.Monad (unless, guard, foldM, when)
58 import Data.Foldable (for_, find)
59 import qualified Data.Map as M
60 import Data.Maybe (fromMaybe)
61 import qualified Data.Set as S
62 import qualified Text.JSON as J
63
64 import Ganeti.BasicTypes
65 import Ganeti.JSON (toArray)
66 import Ganeti.Locking.Types
67
68 {-
69
70 This module is parametric in the type of locks and lock owners.
71 While we only state minimal requirements for the types, we will
72 consistently use the type variable 'a' for the type of locks and
73 the variable 'b' for the type of the lock owners throughout this
74 module.
75
76 -}
77
78 -- | Data type describing the way a lock can be owned.
79 data OwnerState = OwnShared | OwnExclusive deriving (Ord, Eq, Show)
80
81 -- | Type describing indirect ownership on a lock. We keep the set
82 -- of all (lock, owner)-pairs for locks that are implied in the given
83 -- lock, annotated with the type of ownership (shared or exclusive).
84 type IndirectOwners a b = M.Map (a, b) OwnerState
85
86 -- | The state of a lock that is taken. Besides the state of the lock
87 -- itself, we also keep track of all other lock allocation that affect
88 -- the given lock by means of implication.
89 data AllocationState a b = Exclusive b (IndirectOwners a b)
90 | Shared (S.Set b) (IndirectOwners a b)
91 deriving (Eq, Show)
92
93 -- | Compute the set of indirect owners from the information about
94 -- indirect ownership.
95 indirectOwners :: (Ord a, Ord b) => M.Map (a, b) OwnerState -> S.Set b
96 indirectOwners = S.map snd . M.keysSet
97
98 -- | Compute the (zero or one-elment) set of exclusive indirect owners.
99 indirectExclusives :: (Ord a, Ord b) => M.Map (a, b) OwnerState -> S.Set b
100 indirectExclusives = indirectOwners . M.filter (== OwnExclusive)
101
102 {-| Representation of a Lock allocation
103
104 To keep queries for locks efficient, we keep two
105 associations, with the invariant that they fit
106 together: the association from locks to their
107 allocation state, and the association from an
108 owner to the set of locks owned. As we do not
109 export the constructor, the problem of keeping
110 this invariant reduces to only exporting functions
111 that keep the invariant.
112
113 -}
114
115 data LockAllocation a b =
116 LockAllocation { laLocks :: M.Map a (AllocationState a b)
117 , laOwned :: M.Map b (M.Map a OwnerState)
118 }
119 deriving (Eq, Show)
120
121 -- | A state with all locks being free.
122 emptyAllocation :: (Ord a, Ord b) => LockAllocation a b
123 emptyAllocation =
124 LockAllocation { laLocks = M.empty
125 , laOwned = M.empty
126 }
127
128 -- | Obtain the list of all owners holding at least a single lock.
129 lockOwners :: Ord b => LockAllocation a b -> [b]
130 lockOwners = M.keys . laOwned
131
132 -- | Obtain the locks held by a given owner. The locks are reported
133 -- as a map from the owned locks to the form of ownership (OwnShared
134 -- or OwnExclusive).
135 listLocks :: Ord b => b -> LockAllocation a b -> M.Map a OwnerState
136 listLocks owner = fromMaybe M.empty . M.lookup owner . laOwned
137
138 -- | List all locks currently (directly or indirectly) owned by someone.
139 listAllLocks :: Ord b => LockAllocation a b -> [a]
140 listAllLocks = M.keys . laLocks
141
142 -- | Map an AllocationState to a list of pairs of owners and type of
143 -- ownership, showing the direct owners only.
144 toOwnersList :: AllocationState a b -> [(b, OwnerState)]
145 toOwnersList (Exclusive owner _) = [(owner, OwnExclusive)]
146 toOwnersList (Shared owners _) = map (flip (,) OwnShared) . S.elems $ owners
147
148 -- | List all locks currently (directly of indirectly) in use together
149 -- with the direct owners.
150 listAllLocksOwners :: LockAllocation a b -> [(a, [(b, OwnerState)])]
151 listAllLocksOwners = M.toList . M.map toOwnersList . laLocks
152
153 -- | Returns 'True' if the given owner holds the given lock at the given
154 -- ownership level or higher. This means that querying for a shared lock
155 -- returns 'True' of the owner holds the lock in shared or exlusive mode.
156 holdsLock :: (Ord a, Ord b)
157 => b -> a -> OwnerState -> LockAllocation a b -> Bool
158 holdsLock owner lock state = (>= Just state) . M.lookup lock . listLocks owner
159
160 -- | Data Type describing a change request on a single lock.
161 data LockRequest a = LockRequest { lockAffected :: a
162 , lockRequestType :: Maybe OwnerState
163 }
164 deriving (Eq, Show, Ord)
165
166 instance J.JSON a => J.JSON (LockRequest a) where
167 showJSON (LockRequest a Nothing) = J.showJSON (a, "release")
168 showJSON (LockRequest a (Just OwnShared)) = J.showJSON (a, "shared")
169 showJSON (LockRequest a (Just OwnExclusive)) = J.showJSON (a, "exclusive")
170 readJSON (J.JSArray [a, J.JSString tp]) =
171 case J.fromJSString tp of
172 "release" -> LockRequest <$> J.readJSON a <*> pure Nothing
173 "shared" -> LockRequest <$> J.readJSON a <*> pure (Just OwnShared)
174 "exclusive" -> LockRequest <$> J.readJSON a <*> pure (Just OwnExclusive)
175 _ -> J.Error $ "malformed request type: " ++ J.fromJSString tp
176 readJSON x = J.Error $ "malformed lock request: " ++ show x
177
178 -- | Lock request for an exclusive lock.
179 requestExclusive :: a -> LockRequest a
180 requestExclusive lock = LockRequest { lockAffected = lock
181 , lockRequestType = Just OwnExclusive }
182
183 -- | Lock request for a shared lock.
184 requestShared :: a -> LockRequest a
185 requestShared lock = LockRequest { lockAffected = lock
186 , lockRequestType = Just OwnShared }
187
188 -- | Request to release a lock.
189 requestRelease :: a -> LockRequest a
190 requestRelease lock = LockRequest { lockAffected = lock
191 , lockRequestType = Nothing }
192
193 -- | Update the Allocation state of a lock according to a given
194 -- function.
195 updateAllocState :: (Ord a, Ord b)
196 => (Maybe (AllocationState a b) -> AllocationState a b)
197 -> LockAllocation a b -> a -> LockAllocation a b
198 updateAllocState f state lock =
199 let locks' = M.alter (find (/= Shared S.empty M.empty) . Just . f)
200 lock (laLocks state)
201 in state { laLocks = locks' }
202
203 -- | Internal function to update the state according to a single
204 -- lock request, assuming all prerequisites are met.
205 updateLock :: (Ord a, Ord b)
206 => b
207 -> LockAllocation a b -> LockRequest a -> LockAllocation a b
208 updateLock owner state (LockRequest lock (Just OwnExclusive)) =
209 let locks = laLocks state
210 lockstate' = case M.lookup lock locks of
211 Just (Exclusive _ i) -> Exclusive owner i
212 Just (Shared _ i) -> Exclusive owner i
213 Nothing -> Exclusive owner M.empty
214 locks' = M.insert lock lockstate' locks
215 ownersLocks' = M.insert lock OwnExclusive $ listLocks owner state
216 owned' = M.insert owner ownersLocks' $ laOwned state
217 in state { laLocks = locks', laOwned = owned' }
218 updateLock owner state (LockRequest lock (Just OwnShared)) =
219 let ownersLocks' = M.insert lock OwnShared $ listLocks owner state
220 owned' = M.insert owner ownersLocks' $ laOwned state
221 locks = laLocks state
222 lockState' = case M.lookup lock locks of
223 Just (Exclusive _ i) -> Shared (S.singleton owner) i
224 Just (Shared s i) -> Shared (S.insert owner s) i
225 _ -> Shared (S.singleton owner) M.empty
226 locks' = M.insert lock lockState' locks
227 in state { laLocks = locks', laOwned = owned' }
228 updateLock owner state (LockRequest lock Nothing) =
229 let ownersLocks' = M.delete lock $ listLocks owner state
230 owned = laOwned state
231 owned' = if M.null ownersLocks'
232 then M.delete owner owned
233 else M.insert owner ownersLocks' owned
234 update (Just (Exclusive x i)) = if x == owner
235 then Shared S.empty i
236 else Exclusive x i
237 update (Just (Shared s i)) = Shared (S.delete owner s) i
238 update Nothing = Shared S.empty M.empty
239 in updateAllocState update (state { laOwned = owned' }) lock
240
241 -- | Update the set of indirect ownerships of a lock by the given function.
242 updateIndirectSet :: (Ord a, Ord b)
243 => (IndirectOwners a b -> IndirectOwners a b)
244 -> LockAllocation a b -> a -> LockAllocation a b
245 updateIndirectSet f =
246 let update (Just (Exclusive x i)) = Exclusive x (f i)
247 update (Just (Shared s i)) = Shared s (f i)
248 update Nothing = Shared S.empty (f M.empty)
249 in updateAllocState update
250
251 -- | Update all indirect onwerships of a given lock.
252 updateIndirects :: (Lock a, Ord b)
253 => b
254 -> LockAllocation a b -> LockRequest a -> LockAllocation a b
255 updateIndirects owner state req =
256 let lock = lockAffected req
257 fn = case lockRequestType req of
258 Nothing -> M.delete (lock, owner)
259 Just tp -> M.insert (lock, owner) tp
260 in foldl (updateIndirectSet fn) state $ lockImplications lock
261
262 -- | Update the locks of an owner according to the given request. Return
263 -- the pair of the new state and the result of the operation, which is the
264 -- the set of owners on which the operation was blocked on. so an empty set is
265 -- success, and the state is updated if, and only if, the returned set is emtpy.
266 -- In that way, it can be used in atomicModifyIORef.
267 updateLocks :: (Lock a, Ord b)
268 => b
269 -> [LockRequest a]
270 -> LockAllocation a b -> (LockAllocation a b, Result (S.Set b))
271 updateLocks owner reqs state = genericResult ((,) state . Bad) (second Ok) $ do
272 unless ((==) (length reqs) . S.size . S.fromList $ map lockAffected reqs)
273 . runListHead (return ())
274 (fail . (++) "Inconsitent requests for lock " . show) $ do
275 r <- reqs
276 r' <- reqs
277 guard $ r /= r'
278 guard $ lockAffected r == lockAffected r'
279 return $ lockAffected r
280 let current = listLocks owner state
281 unless (M.null current) $ do
282 let (highest, _) = M.findMax current
283 notHolding = not
284 . any (uncurry (==) . ((M.lookup `flip` current) *** Just))
285 orderViolation l = fail $ "Order violation: requesting " ++ show l
286 ++ " while holding " ++ show highest
287 for_ reqs $ \req -> case req of
288 LockRequest lock (Just OwnExclusive)
289 | lock < highest && notHolding ((,) <$> lock : lockImplications lock
290 <*> [OwnExclusive])
291 -> orderViolation lock
292 LockRequest lock (Just OwnShared)
293 | lock < highest && notHolding ((,) <$> lock : lockImplications lock
294 <*> [OwnExclusive, OwnShared])
295 -> orderViolation lock
296 _ -> Ok ()
297 let sharedsHeld = M.keysSet $ M.filter (== OwnShared) current
298 exclusivesRequested = map lockAffected
299 . filter ((== Just OwnExclusive) . lockRequestType)
300 $ reqs
301 runListHead (return ()) fail $ do
302 x <- exclusivesRequested
303 i <- lockImplications x
304 guard $ S.member i sharedsHeld
305 return $ "Order violation: requesting exclusively " ++ show x
306 ++ " while holding a shared lock on the group lock " ++ show i
307 ++ " it belongs to."
308 let blockedOn (LockRequest _ Nothing) = S.empty
309 blockedOn (LockRequest lock (Just OwnExclusive)) =
310 case M.lookup lock (laLocks state) of
311 Just (Exclusive x i) ->
312 S.singleton x `S.union` indirectOwners i
313 Just (Shared xs i) ->
314 xs `S.union` indirectOwners i
315 _ -> S.empty
316 blockedOn (LockRequest lock (Just OwnShared)) =
317 case M.lookup lock (laLocks state) of
318 Just (Exclusive x i) ->
319 S.singleton x `S.union` indirectExclusives i
320 Just (Shared _ i) -> indirectExclusives i
321 _ -> S.empty
322 let indirectBlocked Nothing _ = S.empty
323 indirectBlocked (Just OwnShared) lock =
324 case M.lookup lock (laLocks state) of
325 Just (Exclusive x _) -> S.singleton x
326 _ -> S.empty
327 indirectBlocked (Just OwnExclusive) lock =
328 case M.lookup lock (laLocks state) of
329 Just (Exclusive x _) -> S.singleton x
330 Just (Shared xs _) -> xs
331 _ -> S.empty
332 let direct = S.unions $ map blockedOn reqs
333 indirect = reqs >>= \req ->
334 map (indirectBlocked (lockRequestType req))
335 . lockImplications $ lockAffected req
336 let blocked = S.delete owner . S.unions $ direct:indirect
337 let state' = foldl (updateLock owner) state reqs
338 state'' = foldl (updateIndirects owner) state' reqs
339 return (if S.null blocked then state'' else state, blocked)
340
341 -- | Manipluate all locks of the owner with a given property.
342 manipulateLocksPredicate :: (Lock a, Ord b)
343 => (a -> LockRequest a)
344 -> (a -> Bool)
345 -> b -> LockAllocation a b -> LockAllocation a b
346 manipulateLocksPredicate req prop owner state =
347 fst . flip (updateLocks owner) state . map req
348 . filter prop
349 . M.keys
350 $ listLocks owner state
351
352 -- | Compute the state after an owner releases all its locks that
353 -- satisfy a certain property.
354 freeLocksPredicate :: (Lock a, Ord b)
355 => (a -> Bool)
356 -> LockAllocation a b -> b -> LockAllocation a b
357 freeLocksPredicate prop = flip $ manipulateLocksPredicate requestRelease prop
358
359 -- | Compute the state after an onwer releases all its locks.
360 freeLocks :: (Lock a, Ord b) => LockAllocation a b -> b -> LockAllocation a b
361 freeLocks = freeLocksPredicate (const True)
362
363 {-| Serializaiton of Lock Allocations
364
365 To serialize a lock allocation, we only remember which owner holds
366 which locks at which level (shared or exclusive). From this information,
367 everything else can be reconstructed, simply using updateLocks.
368 -}
369
370 instance J.JSON OwnerState where
371 showJSON OwnShared = J.showJSON "shared"
372 showJSON OwnExclusive = J.showJSON "exclusive"
373 readJSON (J.JSString x) = let s = J.fromJSString x
374 in case s of
375 "shared" -> J.Ok OwnShared
376 "exclusive" -> J.Ok OwnExclusive
377 _ -> J.Error $ "Unknown owner type " ++ s
378 readJSON _ = J.Error "Owner type not encoded as a string"
379
380 -- | Read a lock-ownerstate pair from JSON.
381 readLockOwnerstate :: (J.JSON a) => J.JSValue -> J.Result (a, OwnerState)
382 readLockOwnerstate (J.JSArray [x, y]) = liftA2 (,) (J.readJSON x) (J.readJSON y)
383 readLockOwnerstate x = fail $ "lock-ownerstate pairs are encoded as arrays"
384 ++ " of length 2, but found " ++ show x
385
386 -- | Read an owner-lock pair from JSON.
387 readOwnerLock :: (J.JSON a, J.JSON b)
388 => J.JSValue -> J.Result (b, [(a, OwnerState)])
389 readOwnerLock (J.JSArray [x, J.JSArray ys]) =
390 liftA2 (,) (J.readJSON x) (mapM readLockOwnerstate ys)
391 readOwnerLock x = fail $ "Expected pair of owner and list of owned locks,"
392 ++ " but found " ++ show x
393
394 -- | Transform a lock-ownerstate pair into a LockRequest.
395 toRequest :: (a, OwnerState) -> LockRequest a
396 toRequest (a, OwnExclusive) = requestExclusive a
397 toRequest (a, OwnShared) = requestShared a
398
399 -- | Obtain a LockAllocation from a given owner-locks list.
400 -- The obtained allocation is the one obtained if the respective owners
401 -- requested their locks sequentially.
402 allocationFromOwners :: (Lock a, Ord b, Show b)
403 => [(b, [(a, OwnerState)])]
404 -> J.Result (LockAllocation a b)
405 allocationFromOwners =
406 let allocateOneOwner s (o, req) = do
407 let (s', result) = updateLocks o (map toRequest req) s
408 when (result /= Ok S.empty) . fail
409 . (++) ("Inconsistent lock status for " ++ show o ++ ": ")
410 $ case result of
411 Bad err -> err
412 Ok blocked -> "blocked on " ++ show (S.toList blocked)
413 return s'
414 in foldM allocateOneOwner emptyAllocation
415
416 instance (Lock a, J.JSON a, Ord b, J.JSON b, Show b)
417 => J.JSON (LockAllocation a b) where
418 showJSON = J.showJSON . M.toList . M.map M.toList . laOwned
419 readJSON x = do
420 xs <- toArray x
421 owned <- mapM readOwnerLock xs
422 allocationFromOwners owned