Synnefo » snf-ganeti

  , LockRequest(..)

  , requestExclusive

  , requestShared

  , requestRelease

  , updateLocks

import Control.Arrow (second, (***))

import Control.Monad

import Data.Foldable (for_)

import Ganeti.BasicTypes

-- | Data Type describing a change request on a single lock.

data LockRequest a = LockRequest { lockAffected :: a

                                 , lockRequestType :: Maybe OwnerState

                                 }

                     deriving (Eq, Show)

-- | Lock request for an exclusive lock.

requestExclusive :: a -> LockRequest a

requestExclusive lock = LockRequest { lockAffected = lock

                                    , lockRequestType = Just OwnExclusive }

-- | Lock request for a shared lock.

requestShared :: a -> LockRequest a

requestShared lock = LockRequest { lockAffected = lock

                                 , lockRequestType = Just OwnShared }

-- | Request to release a lock.

requestRelease :: a -> LockRequest a

requestRelease lock = LockRequest { lockAffected = lock

                                  , lockRequestType = Nothing }

-- | Internal function to update the state according to a single

-- lock request, assuming all prerequisites are met.

updateLock :: (Ord a, Ord b)

           => b

           -> LockAllocation a b -> LockRequest a -> LockAllocation a b

updateLock owner state (LockRequest lock (Just OwnExclusive)) =

  let locks' = M.insert lock (Exclusive owner) $ laLocks state

      ownersLocks' = M.insert lock OwnExclusive $ listLocks owner state

      owned' = M.insert owner ownersLocks' $ laOwned state

  in state { laLocks = locks', laOwned = owned' }

updateLock owner state (LockRequest lock (Just OwnShared)) =

  let ownersLocks' = M.insert lock OwnShared $ listLocks owner state

      owned' = M.insert owner ownersLocks' $ laOwned state

      locks = laLocks state

      lockState' = case M.lookup lock locks of

        Just (Shared s) -> Shared (S.insert owner s)

        _ -> Shared $ S.singleton owner

      locks' = M.insert lock lockState' locks

  in state { laLocks = locks', laOwned = owned' }

updateLock owner state (LockRequest lock Nothing) =

  let ownersLocks' = M.delete lock $ listLocks owner state

      owned = laOwned state

      owned' = if M.null ownersLocks'

                 then M.delete owner owned

                 else M.insert owner ownersLocks' owned

      locks = laLocks state

      lockRemoved = M.delete lock locks

      locks' = case M.lookup lock locks of

                 Nothing -> locks

                 Just (Exclusive x) ->

                   if x == owner then lockRemoved else locks

                 Just (Shared s)

                   -> let s' = S.delete owner s

                      in if S.null s'

                        then lockRemoved

                        else M.insert lock (Shared s') locks

  in state { laLocks = locks', laOwned = owned' }

-- | Update the locks of an owner according to the given request. Return

-- the pair of the new state and the result of the operation, which is the

-- the set of owners on which the operation was blocked on. so an empty set is

-- success, and the state is updated if, and only if, the returned set is emtpy.

-- In that way, it can be used in atomicModifyIORef.

updateLocks :: (Ord a, Show a, Ord b)

               => b

               -> [LockRequest a]

               -> LockAllocation a b -> (LockAllocation a b, Result (S.Set b))

updateLocks owner reqs state = genericResult ((,) state . Bad) (second Ok) $ do

  runListHead (return ())

              (fail . (++) "Inconsitent requests for lock " . show) $ do

      r <- reqs

      r' <- reqs

      guard $ r /= r'

      guard $ lockAffected r == lockAffected r'

      return $ lockAffected r

  let current = listLocks owner state

  unless (M.null current) $ do

    let (highest, _) = M.findMax current

        notHolding = not

                     . any (uncurry (==) . ((M.lookup `flip` current) *** Just))

        orderViolation l = fail $ "Order violation: requesting " ++ show l

                                   ++ " while holding " ++ show highest

    for_ reqs $ \req -> case req of

      LockRequest lock (Just OwnExclusive)

        | lock < highest && notHolding [ (lock, OwnExclusive) ]

        -> orderViolation lock

      LockRequest lock (Just OwnShared)

        | lock < highest && notHolding [ (lock, OwnExclusive)

                                       , (lock, OwnExclusive)]

        -> orderViolation lock

      _ -> Ok ()

  let blockedOn (LockRequest  _ Nothing) = S.empty

      blockedOn (LockRequest lock (Just OwnExclusive)) =

        case M.lookup lock (laLocks state) of

          Just (Exclusive x) -> S.singleton x

          Just (Shared xs) -> xs

          _ -> S.empty

      blockedOn (LockRequest lock (Just OwnShared)) =

        case M.lookup lock (laLocks state) of

          Just (Exclusive x) -> S.singleton x

          _ -> S.empty

  let blocked = S.delete owner . S.unions $ map blockedOn reqs

  let state' = foldl (updateLock owner) state reqs

  return (if S.null blocked then state' else state, blocked)