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