| {-# LANGUAGE BangPatterns #-} |
| {-| Implementation of a priority waiting structure for locks. |
| |
| -} |
| |
| {- |
| |
| Copyright (C) 2014 Google Inc. |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are |
| met: |
| |
| 1. Redistributions of source code must retain the above copyright notice, |
| this list of conditions and the following disclaimer. |
| |
| 2. Redistributions in binary form must reproduce the above copyright |
| notice, this list of conditions and the following disclaimer in the |
| documentation and/or other materials provided with the distribution. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS |
| IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED |
| TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR |
| PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR |
| CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, |
| EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, |
| PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR |
| PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF |
| LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING |
| NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS |
| SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |
| |
| -} |
| |
| module Ganeti.Locking.Waiting |
| ( LockWaiting |
| , ExtWaiting |
| , emptyWaiting |
| , updateLocks |
| , updateLocksWaiting |
| , safeUpdateLocksWaiting |
| , getAllocation |
| , getPendingOwners |
| , hasPendingRequest |
| , removePendingRequest |
| , releaseResources |
| , getPendingRequests |
| , extRepr |
| , fromExtRepr |
| , freeLocksPredicate |
| , downGradeLocksPredicate |
| , intersectLocks |
| , opportunisticLockUnion |
| , guardedOpportunisticLockUnion |
| ) where |
| |
| import Control.Arrow ((&&&), (***), second) |
| import Control.Monad (liftM) |
| import Data.List (sort, foldl') |
| import qualified Data.Map as M |
| import Data.Maybe (fromMaybe) |
| import qualified Data.Set as S |
| import qualified Text.JSON as J |
| |
| import Ganeti.BasicTypes |
| import qualified Ganeti.Locking.Allocation as L |
| import Ganeti.Locking.Types (Lock) |
| |
| {- |
| |
| This module is parametric in the type of locks, lock owners, and priorities of |
| the request. While we state only minimal requirements for the types, we will |
| consistently use the type variable 'a' for the type of locks, the variable 'b' |
| for the type of the lock owners, and 'c' for the type of priorities throughout |
| this module. The type 'c' will have to instance Ord, and the smallest value |
| indicate the most important priority. |
| |
| -} |
| |
| {-| Representation of the waiting structure |
| |
| For any request we cannot fullfill immediately, we have a set of lock |
| owners it is blocked on. We can pick one of the owners, the smallest say; |
| then we know that this request cannot possibly be fulfilled until this |
| owner does something. So we can index the pending requests by such a chosen |
| owner and only revisit them once the owner acts. For the requests to revisit |
| we need to do so in order of increasing priority; this order can be maintained |
| by the Set data structure, where we make use of the fact that tuples are ordered |
| lexicographically. |
| |
| Additionally, we keep track of which owners have pending requests, to disallow |
| them any other lock tasks till their request is fulfilled. To allow canceling |
| of pending requests, we also keep track on which owner their request is pending |
| on and what the request was. |
| |
| -} |
| |
| data LockWaiting a b c = |
| LockWaiting { lwAllocation :: L.LockAllocation a b |
| , lwPending :: M.Map b (S.Set (c, b, [L.LockRequest a])) |
| , lwPendingOwners :: M.Map b (b, (c, b, [L.LockRequest a])) |
| } deriving Show |
| |
| -- | A state without locks and pending requests. |
| emptyWaiting :: (Ord a, Ord b, Ord c) => LockWaiting a b c |
| emptyWaiting = |
| LockWaiting { lwAllocation = L.emptyAllocation |
| , lwPending = M.empty |
| , lwPendingOwners = M.empty |
| } |
| |
| -- | Get the set of owners with pending lock requests. |
| getPendingOwners :: LockWaiting a b c -> S.Set b |
| getPendingOwners = M.keysSet . lwPendingOwners |
| |
| -- | Predicate on whether an owner has a pending lock request. |
| hasPendingRequest :: Ord b => b -> LockWaiting a b c -> Bool |
| hasPendingRequest owner = M.member owner . lwPendingOwners |
| |
| -- | Get the allocation state from the waiting state |
| getAllocation :: LockWaiting a b c -> L.LockAllocation a b |
| getAllocation = lwAllocation |
| |
| -- | Get the list of all pending requests. |
| getPendingRequests :: (Ord a, Ord b, Ord c) |
| => LockWaiting a b c -> S.Set (c, b, [L.LockRequest a]) |
| getPendingRequests = S.unions . M.elems . lwPending |
| |
| -- | Type of the extensional representation of a LockWaiting. |
| type ExtWaiting a b c = (L.LockAllocation a b, S.Set (c, b, [L.LockRequest a])) |
| |
| -- | Get a representation, comparable by (==), that captures the extensional |
| -- behaviour. In other words, @(==) `on` extRepr@ is a bisumlation. |
| extRepr :: (Ord a, Ord b, Ord c) |
| => LockWaiting a b c -> ExtWaiting a b c |
| extRepr = getAllocation &&& getPendingRequests |
| |
| -- | Internal function to fulfill one request if possible, and keep track of |
| -- the owners to be notified. The type is chosen to be suitable as fold |
| -- operation. |
| -- |
| -- This function calls the later defined updateLocksWaiting', as they are |
| -- mutually recursive. |
| tryFulfillRequest :: (Lock a, Ord b, Ord c) |
| => (LockWaiting a b c, S.Set b) |
| -> (c, b, [L.LockRequest a]) |
| -> (LockWaiting a b c, S.Set b) |
| tryFulfillRequest (waiting, toNotify) (prio, owner, req) = |
| let (waiting', (_, newNotify)) = updateLocksWaiting' prio owner req waiting |
| in (waiting', toNotify `S.union` newNotify) |
| |
| -- | Internal function to recursively follow the consequences of a change. |
| revisitRequests :: (Lock a, Ord b, Ord c) |
| => S.Set b -- ^ the owners where the requests keyed by them |
| -- already have been revisited |
| -> S.Set b -- ^ the owners where requests keyed by them need |
| -- to be revisited |
| -> LockWaiting a b c -- ^ state before revisiting |
| -> (S.Set b, LockWaiting a b c) -- ^ owners visited and state |
| -- after revisiting |
| revisitRequests notify todo state = |
| let getRequests (pending, reqs) owner = |
| (M.delete owner pending |
| , fromMaybe S.empty (M.lookup owner pending) `S.union` reqs) |
| (pending', requests) = S.foldl' getRequests (lwPending state, S.empty) |
| todo |
| revisitedOwners = S.map (\(_, o, _) -> o) requests |
| pendingOwners' = S.foldl' (flip M.delete) (lwPendingOwners state) |
| revisitedOwners |
| state' = state { lwPending = pending', lwPendingOwners = pendingOwners' } |
| (!state'', !notify') = S.foldl' tryFulfillRequest (state', notify) |
| requests |
| done = notify `S.union` todo |
| !newTodo = notify' S.\\ done |
| in if S.null todo |
| then (notify, state) |
| else revisitRequests done newTodo state'' |
| |
| -- | Update the locks on an onwer according to the given request, if possible. |
| -- Additionally (if the request succeeds) fulfill any pending requests that |
| -- became possible through this request. Return the new state of the waiting |
| -- structure, the result of the operation, and a list of owner whose requests |
| -- have been fulfilled. The result is, as for lock allocation, the set of owners |
| -- the request is blocked on. Again, the type is chosen to be suitable for use |
| -- in atomicModifyIORef. |
| updateLocks' :: (Lock a, Ord b, Ord c) |
| => b |
| -> [L.LockRequest a] |
| -> LockWaiting a b c |
| -> (LockWaiting a b c, (Result (S.Set b), S.Set b)) |
| updateLocks' owner reqs state = |
| let (!allocation', !result) = L.updateLocks owner reqs (lwAllocation state) |
| state' = state { lwAllocation = allocation' } |
| (!notify, !state'') = revisitRequests S.empty (S.singleton owner) state' |
| in if M.member owner $ lwPendingOwners state |
| then ( state |
| , (Bad "cannot update locks while having pending requests", S.empty) |
| ) |
| else if result /= Ok S.empty -- skip computation if request could not |
| -- be handled anyway |
| then (state, (result, S.empty)) |
| else let pendingOwners' = lwPendingOwners state'' |
| toNotify = S.filter (not . flip M.member pendingOwners') |
| notify |
| in (state'', (result, toNotify)) |
| |
| -- | Update locks as soon as possible. If the request cannot be fulfilled |
| -- immediately add the request to the waiting queue. The first argument is |
| -- the priority at which the owner is waiting, the remaining are as for |
| -- updateLocks', and so is the output. |
| updateLocksWaiting' :: (Lock a, Ord b, Ord c) |
| => c |
| -> b |
| -> [L.LockRequest a] |
| -> LockWaiting a b c |
| -> (LockWaiting a b c, (Result (S.Set b), S.Set b)) |
| updateLocksWaiting' prio owner reqs state = |
| let (state', (result, notify)) = updateLocks' owner reqs state |
| !state'' = case result of |
| Bad _ -> state' -- bad requests cannot be queued |
| Ok empty | S.null empty -> state' |
| Ok blocked -> let blocker = S.findMin blocked |
| owners = M.insert owner (blocker, (prio, owner, reqs)) |
| $ lwPendingOwners state |
| pendingEntry = S.insert (prio, owner, reqs) |
| . fromMaybe S.empty |
| . M.lookup blocker |
| $ lwPending state |
| pending = M.insert blocker pendingEntry |
| $ lwPending state |
| in state' { lwPendingOwners = owners |
| , lwPending = pending |
| } |
| in (state'', (result, notify)) |
| |
| -- | Predicate whether a request is already fulfilled in a given state |
| -- and no requests for that owner are pending. |
| requestFulfilled :: (Ord a, Ord b) |
| => b -> [L.LockRequest a] -> LockWaiting a b c -> Bool |
| requestFulfilled owner req state = |
| let locks = L.listLocks owner $ lwAllocation state |
| isFulfilled r = M.lookup (L.lockAffected r) locks |
| == L.lockRequestType r |
| in not (hasPendingRequest owner state) && all isFulfilled req |
| |
| -- | Update the locks on an onwer according to the given request, if possible. |
| -- Additionally (if the request succeeds) fulfill any pending requests that |
| -- became possible through this request. Return the new state of the waiting |
| -- structure, the result of the operation, and a list of owners to be notified. |
| -- The result is, as for lock allocation, the set of owners the request is |
| -- blocked on. Again, the type is chosen to be suitable for use in |
| -- atomicModifyIORef. |
| -- For convenience, fulfilled requests are always accepted. |
| updateLocks :: (Lock a, Ord b, Ord c) |
| => b |
| -> [L.LockRequest a] |
| -> LockWaiting a b c |
| -> (LockWaiting a b c, (Result (S.Set b), S.Set b)) |
| updateLocks owner req state = |
| if requestFulfilled owner req state |
| then (state, (Ok S.empty, S.empty)) |
| else second (second $ S.delete owner) $ updateLocks' owner req state |
| |
| -- | Update locks as soon as possible. If the request cannot be fulfilled |
| -- immediately add the request to the waiting queue. The first argument is |
| -- the priority at which the owner is waiting, the remaining are as for |
| -- updateLocks, and so is the output. |
| -- For convenience, fulfilled requests are always accepted. |
| updateLocksWaiting :: (Lock a, Ord b, Ord c) |
| => c |
| -> b |
| -> [L.LockRequest a] |
| -> LockWaiting a b c |
| -> (LockWaiting a b c, (Result (S.Set b), S.Set b)) |
| updateLocksWaiting prio owner req state = |
| if requestFulfilled owner req state |
| then (state, (Ok S.empty, S.empty)) |
| else second (second $ S.delete owner) |
| $ updateLocksWaiting' prio owner req state |
| |
| |
| -- | Compute the state of a waiting after an owner gives up |
| -- on his pending request. |
| removePendingRequest :: (Lock a, Ord b, Ord c) |
| => b -> LockWaiting a b c -> LockWaiting a b c |
| removePendingRequest owner state = |
| let pendingOwners = lwPendingOwners state |
| pending = lwPending state |
| in case M.lookup owner pendingOwners of |
| Nothing -> state |
| Just (blocker, entry) -> |
| let byBlocker = fromMaybe S.empty . M.lookup blocker $ pending |
| byBlocker' = S.delete entry byBlocker |
| pending' = if S.null byBlocker' |
| then M.delete blocker pending |
| else M.insert blocker byBlocker' pending |
| in state { lwPendingOwners = M.delete owner pendingOwners |
| , lwPending = pending' |
| } |
| |
| -- | A repeatable version of `updateLocksWaiting`. If the owner has a pending |
| -- request and the pending request is equal to the current one, do nothing; |
| -- otherwise call updateLocksWaiting. |
| safeUpdateLocksWaiting :: (Lock a, Ord b, Ord c) |
| => c |
| -> b |
| -> [L.LockRequest a] |
| -> LockWaiting a b c |
| -> (LockWaiting a b c, (Result (S.Set b), S.Set b)) |
| safeUpdateLocksWaiting prio owner req state = |
| if hasPendingRequest owner state |
| && S.singleton req |
| == (S.map (\(_, _, r) -> r) |
| . S.filter (\(_, b, _) -> b == owner) $ getPendingRequests state) |
| then let (_, answer) = updateLocksWaiting prio owner req |
| $ removePendingRequest owner state |
| in (state, answer) |
| else updateLocksWaiting prio owner req state |
| |
| -- | Convenience function to release all pending requests and locks |
| -- of a given owner. Return the new configuration and the owners to |
| -- notify. |
| releaseResources :: (Lock a, Ord b, Ord c) |
| => b -> LockWaiting a b c -> (LockWaiting a b c, S.Set b) |
| releaseResources owner state = |
| let state' = removePendingRequest owner state |
| request = map L.requestRelease |
| . M.keys . L.listLocks owner $ getAllocation state' |
| (state'', (_, notify)) = updateLocks owner request state' |
| in (state'', notify) |
| |
| -- | Obtain a LockWaiting from its extensional representation. |
| fromExtRepr :: (Lock a, Ord b, Ord c) |
| => ExtWaiting a b c -> LockWaiting a b c |
| fromExtRepr (alloc, pending) = |
| S.foldl' (\s (prio, owner, req) -> |
| fst $ updateLocksWaiting prio owner req s) |
| (emptyWaiting { lwAllocation = alloc }) |
| pending |
| |
| instance (Lock a, J.JSON a, Ord b, J.JSON b, Show b, Ord c, J.JSON c) |
| => J.JSON (LockWaiting a b c) where |
| showJSON = J.showJSON . extRepr |
| readJSON = liftM fromExtRepr . J.readJSON |
| |
| -- | Manipulate a all locks of an owner that have a given property. Also |
| -- drop all pending requests. |
| manipulateLocksPredicate :: (Lock a, Ord b, Ord c) |
| => (a -> L.LockRequest a) |
| -> (a -> Bool) |
| -> b |
| -> LockWaiting a b c -> (LockWaiting a b c, S.Set b) |
| manipulateLocksPredicate req prop owner state = |
| second snd . flip (updateLocks owner) (removePendingRequest owner state) |
| . map req . filter prop . M.keys |
| . L.listLocks owner $ getAllocation state |
| |
| -- | Free all Locks of a given owner satisfying a given predicate. As this |
| -- operation is supposed to unconditionally suceed, all pending requests |
| -- are dropped as well. |
| freeLocksPredicate :: (Lock a, Ord b, Ord c) |
| => (a -> Bool) |
| -> b |
| -> LockWaiting a b c -> (LockWaiting a b c, S.Set b) |
| freeLocksPredicate = manipulateLocksPredicate L.requestRelease |
| |
| -- | Downgrade all locks of a given owner that satisfy a given predicate. As |
| -- this operation is supposed to unconditionally suceed, all pending requests |
| -- are dropped as well. |
| downGradeLocksPredicate :: (Lock a, Ord b, Ord c) |
| => (a -> Bool) |
| -> b |
| -> LockWaiting a b c -> (LockWaiting a b c, S.Set b) |
| downGradeLocksPredicate = manipulateLocksPredicate L.requestShared |
| |
| -- | Intersect locks to a given set. |
| intersectLocks :: (Lock a, Ord b, Ord c) |
| => [a] |
| -> b |
| -> LockWaiting a b c -> (LockWaiting a b c, S.Set b) |
| intersectLocks locks = freeLocksPredicate (not . flip elem locks) |
| |
| -- | Opprotunistically allocate locks for a given owner; return the set |
| -- of newly actually acquired locks (i.e., locks already held before are |
| -- not mentioned). |
| opportunisticLockUnion :: (Lock a, Ord b, Ord c) |
| => b |
| -> [(a, L.OwnerState)] |
| -> LockWaiting a b c |
| -> (LockWaiting a b c, ([a], S.Set b)) |
| opportunisticLockUnion owner reqs state = |
| let locks = L.listLocks owner $ getAllocation state |
| reqs' = sort $ filter (uncurry (<) . (flip M.lookup locks *** Just)) reqs |
| maybeAllocate (s, success) (lock, ownstate) = |
| let (s', (result, _)) = |
| updateLocks owner |
| [(if ownstate == L.OwnShared |
| then L.requestShared |
| else L.requestExclusive) lock] |
| s |
| in (s', if result == Ok S.empty then lock:success else success) |
| in second (flip (,) S.empty) $ foldl' maybeAllocate (state, []) reqs' |
| |
| -- | A guarded version of opportunisticLockUnion; if the number of fulfilled |
| -- requests is not at least the given amount, then do not change anything. |
| guardedOpportunisticLockUnion :: (Lock a, Ord b, Ord c) |
| => Int |
| -> b |
| -> [(a, L.OwnerState)] |
| -> LockWaiting a b c |
| -> (LockWaiting a b c, ([a], S.Set b)) |
| guardedOpportunisticLockUnion count owner reqs state = |
| let (state', (acquired, toNotify)) = opportunisticLockUnion owner reqs state |
| in if length acquired < count |
| then (state, ([], S.empty)) |
| else (state', (acquired, toNotify)) |
