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