content: {-# LANGUAGE TemplateHaskell #-}
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  
  {-| Tests for lock waiting structure.
  
  -}
  
  {-
  
  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 Test.Ganeti.Locking.Waiting (testLocking_Waiting) where
  
  import Control.Applicative (liftA2)
  import Control.Monad (liftM)
  import qualified Data.Map as M
  import qualified Data.Set as S
  import qualified Text.JSON as J
  
  import Test.QuickCheck
  
  import Test.Ganeti.TestCommon
  import Test.Ganeti.TestHelper
  import Test.Ganeti.Locking.Allocation (TestLock, TestOwner, requestSucceeded)
  
  import Ganeti.BasicTypes (isBad, genericResult, runListHead)
  import Ganeti.Locking.Allocation (LockRequest, listLocks)
  import qualified Ganeti.Locking.Allocation as L
  import Ganeti.Locking.Types (Lock)
  import Ganeti.Locking.Waiting
  
  {-
  
  Ganeti.Locking.Waiting is polymorphic in the types of locks, lock owners,
  and priorities. So we can use much simpler types here than Ganeti's
  real locks and lock owners, knowning that polymorphic functions cannot
  exploit the simplicity of the types they're deling with. To avoid code
  duplication, we use the test structure from Test.Ganeti.Locking.Allocation.
  
  -}
  
  {-
  
  All states of a LockWaiting ever available outside the module can be
  obtained from @emptyWaiting@ applying one of the update operations.
  
  -}
  
  data UpdateRequest a b c = Update b [LockRequest a]
                           | UpdateWaiting c b [LockRequest a]
                           | RemovePending b
                           | IntersectRequest b [a]
                           | OpportunisticUnion b [(a, L.OwnerState)]
                           deriving Show
  
  instance (Arbitrary a, Arbitrary b, Arbitrary c)
           => Arbitrary (UpdateRequest a b c) where
    arbitrary =
      frequency [ (2, Update <$> arbitrary <*> (choose (1, 4) >>= vector))
                , (4, UpdateWaiting <$> arbitrary <*> arbitrary
                                    <*> (choose (1, 4) >>= vector))
                , (1, RemovePending <$> arbitrary)
                , (1, IntersectRequest <$> arbitrary
                                       <*> (choose (1, 4) >>= vector))
                , (1, OpportunisticUnion <$> arbitrary
                                         <*> (choose (1, 4) >>= vector))
                ]
  
  -- | Transform an UpdateRequest into the corresponding state transformer.
  asWaitingTrans :: (Lock a, Ord b, Ord c)
                 => LockWaiting a b c -> UpdateRequest a b c -> LockWaiting a b c
  asWaitingTrans state (Update owner req) = fst $ updateLocks owner req state
  asWaitingTrans state (UpdateWaiting prio owner req) =
    fst $ updateLocksWaiting prio owner req state
  asWaitingTrans state (RemovePending owner) = removePendingRequest owner state
  asWaitingTrans state (IntersectRequest owner locks) =
    fst $ intersectLocks locks owner state
  asWaitingTrans state (OpportunisticUnion owner locks) =
    fst $ opportunisticLockUnion owner locks state
  
  
  -- | Fold a sequence of requests to transform a waiting strucutre onto the
  -- empty waiting. As we consider all exported transformations, any waiting
  -- structure can be obtained this way.
  foldUpdates :: (Lock a, Ord b, Ord c)
              => [UpdateRequest a b c] -> LockWaiting a b c
  foldUpdates = foldl asWaitingTrans emptyWaiting
  
  instance (Arbitrary a, Lock a, Arbitrary b, Ord b, Arbitrary c, Ord c)
           => Arbitrary (LockWaiting a b c) where
    arbitrary = foldUpdates <$> (choose (0, 8) >>= vector)
  
  -- | Verify that an owner with a pending request cannot make any
  -- changes to the lock structure.
  prop_NoActionWithPendingRequests :: Property
  prop_NoActionWithPendingRequests =
    forAll (arbitrary :: Gen TestOwner) $ \a ->
    forAll ((arbitrary :: Gen (LockWaiting TestLock TestOwner Integer))
            `suchThat` (S.member a . getPendingOwners)) $ \state ->
    forAll (arbitrary :: Gen [LockRequest TestLock]) $ \req ->
    forAll arbitrary $ \prio ->
    counterexample "Owners with pending requests may not update locks"
    . all (isBad . fst . snd)
    $ [updateLocks, updateLocksWaiting prio] <*> [a] <*> [req] <*> [state]
  
  -- | Quantifier for blocked requests. Quantifies over the generic situation
  -- that there is a state, an owner, and a request that is blocked for that
  -- owner. To obtain such a situation, we use the fact that there must be a
  -- different owner having at least one lock.
  forAllBlocked :: (Testable prop)
                => (LockWaiting TestLock TestOwner Integer -- State
                    -> TestOwner -- The owner of the blocked request
                    -> Integer -- The priority
                    -> [LockRequest TestLock] -- Request
                    -> prop)
                -> Property
  forAllBlocked predicate =
    forAll (arbitrary :: Gen TestOwner) $ \a ->
    forAll (arbitrary :: Gen Integer) $ \prio ->
    forAll (arbitrary `suchThat` (/=) a) $ \b ->
    forAll ((arbitrary :: Gen (LockWaiting TestLock TestOwner Integer))
            `suchThat` foldl (liftA2 (&&)) (const True)
                [ not . S.member a . getPendingOwners
                , M.null . listLocks a . getAllocation
                , not . M.null . listLocks b . getAllocation]) $ \state ->
    forAll ((arbitrary :: Gen [LockRequest TestLock])
            `suchThat` (genericResult (const False) (not . S.null)
                        . fst . snd . flip (updateLocksWaiting prio a) state))
            $ \req ->
    predicate state a prio req
  
  -- | Verify that an owner has a pending request after a waiting request
  -- not fullfilled immediately.
  prop_WaitingRequestsGetPending :: Property
  prop_WaitingRequestsGetPending =
    forAllBlocked $ \state owner prio req ->
    counterexample "After a not immediately fulfilled waiting request, owner\
                   \ must have a pending request"
    . S.member owner . getPendingOwners . fst
    $ updateLocksWaiting prio owner req state
  
  -- | Verify that pending requests get fullfilled once all blockers release
  -- their resources.
  prop_PendingGetFulfilledEventually :: Property
  prop_PendingGetFulfilledEventually =
    forAllBlocked $ \state owner prio req ->
    let oldpending = getPendingOwners state
        (state', (resultBlockers, _)) = updateLocksWaiting prio owner req state
        blockers = genericResult (const S.empty) id resultBlockers
        state'' = S.foldl (\s a -> fst $ releaseResources a s) state'
                    $ S.union oldpending blockers
        finallyOwned = listLocks  owner $ getAllocation state''
    in counterexample "After all blockers and old pending owners give up their\
                      \ resources, a pending request must be granted\
                      \ automatically"
       $ all (requestSucceeded finallyOwned) req
  
  -- | Verify that the owner of a pending request gets notified once all blockers
  -- release their resources.
  prop_PendingGetNotifiedEventually :: Property
  prop_PendingGetNotifiedEventually =
    forAllBlocked $ \state owner prio req ->
    let oldpending = getPendingOwners state
        (state', (resultBlockers, _)) = updateLocksWaiting prio owner req state
        blockers = genericResult (const S.empty) id resultBlockers
        releaseOneOwner (s, tonotify) o =
          let (s', newnotify) = releaseResources o s
          in (s', newnotify `S.union` tonotify)
        (_, notified) = S.foldl releaseOneOwner (state', S.empty)
                          $ S.union oldpending blockers
    in counterexample "After all blockers and old pending owners give up their\
                      \ resources, a pending owner must be notified"
       $ S.member owner notified
  
  -- | Verify that some progress is made after the direct blockers give up their
  -- locks. Note that we cannot guarantee that the original requester gets its
  -- request granted, as someone else might have a more important priority.
  prop_Progress :: Property
  prop_Progress =
    forAllBlocked $ \state owner prio req ->
    let (state', (resultBlockers, _)) = updateLocksWaiting prio owner req state
        blockers = genericResult (const S.empty) id resultBlockers
        releaseOneOwner (s, tonotify) o =
          let (s', newnotify) = releaseResources o s
          in (s', newnotify `S.union` tonotify)
        (_, notified) = S.foldl releaseOneOwner (state', S.empty) blockers
    in counterexample "Some progress must be made after all blockers release\
                      \ their locks"
       . not . S.null $ notified S.\\ blockers
  
  -- | Verify that the notifications send out are sound, i.e., upon notification
  -- the requests actually are fulfilled. To be sure to have at least one
  -- notification we, again, use the scenario that a request is blocked and then
  -- all the blockers release their resources.
  prop_ProgressSound :: Property
  prop_ProgressSound =
    forAllBlocked $ \state owner prio req ->
    let (state', (resultBlockers, _)) = updateLocksWaiting prio owner req state
        blockers = genericResult (const S.empty) id resultBlockers
        releaseOneOwner (s, tonotify) o =
          let (s', newnotify) = releaseResources o s
          in (s', newnotify `S.union` tonotify)
        (state'', notified) = S.foldl releaseOneOwner (state', S.empty) blockers
        requestFulfilled o =
          runListHead False
            (\(_, _, r) ->
                all (requestSucceeded . listLocks o $ getAllocation state'') r)
            . S.toList . S.filter (\(_, b, _) -> b == o)
            . getPendingRequests $ state'
    in counterexample "If an owner gets notified, his request must be satisfied"
       . all requestFulfilled . S.toList $ notified S.\\ blockers
  
  -- | Verify that all pending requests are valid and cannot be fulfilled in
  -- the underlying lock allocation.
  prop_PendingJustified :: Property
  prop_PendingJustified =
    forAll ((arbitrary :: Gen (LockWaiting TestLock TestOwner Integer))
            `suchThat` (not . S.null . getPendingRequests)) $ \state ->
    let isJustified (_, b, req) =
          genericResult (const False) (not . S.null) . snd
          . L.updateLocks b req $ getAllocation state
    in counterexample "Pending requests must be good and not fulfillable"
       . all isJustified . S.toList $ getPendingRequests state
  
  -- | Verify that `updateLocks` is idempotent, except that in the repetition,
  -- no waiters are notified.
  prop_UpdateIdempotent :: Property
  prop_UpdateIdempotent =
    forAll (arbitrary :: Gen (LockWaiting TestLock TestOwner Integer)) $ \state ->
    forAll (arbitrary :: Gen TestOwner) $ \owner ->
    forAll (arbitrary :: Gen [LockRequest TestLock]) $ \req ->
    let (state', (answer', _)) = updateLocks owner req state
        (state'', (answer'', nfy)) = updateLocks owner req state'
    in conjoin [ counterexample ("repeated updateLocks waiting gave different\
                                 \ answers: " ++ show answer' ++ " /= "
                                 ++ show answer'') $ answer' == answer''
               , counterexample "updateLocks not idempotent"
                 $ extRepr state' == extRepr state''
               , counterexample ("notifications (" ++ show nfy ++ ") on replay")
                 $ S.null nfy
               ]
  
  -- | Verify that extRepr . fromExtRepr = id for all valid extensional
  -- representations.
  prop_extReprPreserved :: Property
  prop_extReprPreserved =
    forAll (arbitrary :: Gen (LockWaiting TestLock TestOwner Integer)) $ \state ->
    let rep = extRepr state
        rep' = extRepr $ fromExtRepr rep
    in counterexample "a lock waiting obtained from an extensional representation\
                      \ must have the same extensional representation"
       $ rep' == rep
  
  -- | Verify that any state is indistinguishable from its canonical version
  -- (i.e., the one obtained from the extensional representation) with respect
  -- to updateLocks.
  prop_SimulateUpdateLocks :: Property
  prop_SimulateUpdateLocks =
    forAll (arbitrary :: Gen (LockWaiting TestLock TestOwner Integer)) $ \state ->
    forAll (arbitrary :: Gen TestOwner) $ \owner ->
    forAll (arbitrary :: Gen [LockRequest TestLock]) $ \req ->
    let state' = fromExtRepr $ extRepr state
        (finState, (result, notify)) = updateLocks owner req state
        (finState', (result', notify')) = updateLocks owner req state'
    in counterexample "extRepr-equal states must behave equal on updateLocks"
       $ and [ result == result'
             , notify == notify'
             , extRepr finState == extRepr finState'
             ]
  -- | Verify that any state is indistinguishable from its canonical version
  -- (i.e., the one obtained from the extensional representation) with respect
  -- to updateLocksWaiting.
  prop_SimulateUpdateLocksWaiting :: Property
  prop_SimulateUpdateLocksWaiting =
    forAll (arbitrary :: Gen (LockWaiting TestLock TestOwner Integer)) $ \state ->
    forAll (arbitrary :: Gen TestOwner) $ \owner ->
    forAll (arbitrary :: Gen Integer) $ \prio ->
    forAll (arbitrary :: Gen [LockRequest TestLock]) $ \req ->
    let state' = fromExtRepr $ extRepr state
        (finState, (result, notify)) = updateLocksWaiting prio owner req state
        (finState', (result', notify')) = updateLocksWaiting prio owner req state'
    in counterexample "extRepr-equal states must behave equal on updateLocks"
       $ and [ result == result'
             , notify == notify'
             , extRepr finState == extRepr finState'
             ]
  
  -- | Verify that if a requestor has no pending requests, `safeUpdateWaiting`
  -- conincides with `updateLocksWaiting`.
  prop_SafeUpdateWaitingCorrect :: Property
  prop_SafeUpdateWaitingCorrect  =
    forAll (arbitrary :: Gen TestOwner) $ \owner ->
    forAll ((arbitrary :: Gen (LockWaiting TestLock TestOwner Integer))
            `suchThat` (not . hasPendingRequest owner)) $ \state ->
    forAll (arbitrary :: Gen Integer) $ \prio ->
    forAll (arbitrary :: Gen [LockRequest TestLock]) $ \req ->
    let (state', answer') = updateLocksWaiting prio owner req state
        (state'', answer'') = safeUpdateLocksWaiting prio owner req state
    in conjoin [ counterexample ("safeUpdateLocksWaiting gave different answer: "
                                ++ show answer' ++ " /= " ++ show answer'')
                 $ answer' == answer''
               , counterexample ("safeUpdateLocksWaiting gave different states\
                                 \ after answer " ++ show answer' ++ ": "
                                 ++ show (extRepr state') ++ " /= "
                                 ++ show (extRepr state''))
                 $ extRepr state' == extRepr state''
               ]
  
  -- | Verify that `safeUpdateLocksWaiting` is idempotent, that in the repetition
  -- no notifications are done.
  prop_SafeUpdateWaitingIdempotent :: Property
  prop_SafeUpdateWaitingIdempotent =
    forAll (arbitrary :: Gen (LockWaiting TestLock TestOwner Integer)) $ \state ->
    forAll (arbitrary :: Gen TestOwner) $ \owner ->
    forAll (arbitrary :: Gen Integer) $ \prio ->
    forAll (arbitrary :: Gen [LockRequest TestLock]) $ \req ->
    let (state', (answer', _)) = safeUpdateLocksWaiting prio owner req state
        (state'', (answer'', nfy)) = safeUpdateLocksWaiting prio owner req state'
    in conjoin [ counterexample ("repeated safeUpdateLocks waiting gave different\
                                 \ answers: " ++ show answer' ++ " /= "
                                 ++ show answer'') $ answer' == answer''
               , counterexample "safeUpdateLocksWaiting not idempotent"
                 $ extRepr state' == extRepr state''
               , counterexample ("notifications (" ++ show nfy ++ ") on replay")
                 $ S.null nfy
               ]
  
  -- | Verify that for LockWaiting we have readJSON . showJSON is extensionally
  -- equivalent to Ok.
  prop_ReadShow :: Property
  prop_ReadShow =
    forAll (arbitrary :: Gen (LockWaiting TestLock TestOwner Integer)) $ \state ->
    (liftM extRepr . J.readJSON $ J.showJSON state) ==? (J.Ok $ extRepr state)
  
  -- | Verify that opportunistic union only increases the locks held.
  prop_OpportunisticMonotone :: Property
  prop_OpportunisticMonotone =
    forAll (arbitrary :: Gen (LockWaiting TestLock TestOwner Integer)) $ \state ->
    forAll (arbitrary :: Gen TestOwner) $ \a ->
    forAll ((choose (1,3) >>= vector) :: Gen [(TestLock, L.OwnerState)]) $ \req ->
    let (state', _) = opportunisticLockUnion a req state
        oldOwned = listLocks a $ getAllocation state
        oldLocks = M.keys oldOwned
        newOwned = listLocks a $ getAllocation state'
    in counterexample "Opportunistic union may only increase the set of locks\
                      \ held"
       . flip all oldLocks $ \lock ->
         M.lookup lock newOwned >= M.lookup lock oldOwned
  
  -- | Verify the result list of the opportunistic union: if a lock is not in
  -- the result that, than its state has not changed, and if it is, it is as
  -- requested. The latter property is tested in that liberal way, so that we
  -- really can take arbitrary requests, including those that require both, shared
  -- and exlusive state for the same lock.
  prop_OpportunisticAnswer :: Property
  prop_OpportunisticAnswer =
    forAll (arbitrary :: Gen (LockWaiting TestLock TestOwner Integer)) $ \state ->
    forAll (arbitrary :: Gen TestOwner) $ \a ->
    forAll ((choose (1,3) >>= vector) :: Gen [(TestLock, L.OwnerState)]) $ \req ->
    let (state', (result, _)) = opportunisticLockUnion a req state
        oldOwned = listLocks a $ getAllocation state
        newOwned = listLocks a $ getAllocation state'
        involvedLocks = M.keys oldOwned ++ map fst req
    in conjoin [ counterexample ("Locks not in the answer set " ++ show result
                                   ++ " may not be changed, but found "
                                   ++ show state')
                 . flip all involvedLocks $ \lock ->
                   (lock `elem` result)
                   || (M.lookup lock oldOwned == M.lookup lock newOwned)
               , counterexample ("Locks not in the answer set " ++ show result
                                  ++ " must be as requested, but found "
                                  ++ show state')
                 . flip all involvedLocks $ \lock ->
                   notElem lock result
                   || maybe False (flip elem req . (,) lock)
                        (M.lookup lock newOwned)
               ]
  
  
  testSuite "Locking/Waiting"
   [ 'prop_NoActionWithPendingRequests
   , 'prop_WaitingRequestsGetPending
   , 'prop_PendingGetFulfilledEventually
   , 'prop_PendingGetNotifiedEventually
   , 'prop_Progress
   , 'prop_ProgressSound
   , 'prop_PendingJustified
   , 'prop_extReprPreserved
   , 'prop_UpdateIdempotent
   , 'prop_SimulateUpdateLocks
   , 'prop_SimulateUpdateLocksWaiting
   , 'prop_ReadShow
   , 'prop_SafeUpdateWaitingCorrect
   , 'prop_SafeUpdateWaitingIdempotent
   , 'prop_OpportunisticMonotone
   , 'prop_OpportunisticAnswer
   ]
  