content: {-# LANGUAGE TemplateHaskell #-}
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  
  {-| Tests for lock allocation.
  
  -}
  
  {-
  
  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.Allocation
    ( testLocking_Allocation
    , TestLock
    , TestOwner
    , requestSucceeded
    ) where
  
  import qualified Data.Foldable as F
  import qualified Data.Map as M
  import Data.Maybe (fromMaybe)
  import qualified Data.Set as S
  import qualified Text.JSON as J
  
  import Test.QuickCheck
  
  import Test.Ganeti.TestCommon
  import Test.Ganeti.TestHelper
  
  import Ganeti.BasicTypes
  import Ganeti.Locking.Allocation
  import Ganeti.Locking.Types
  
  {-
  
  Ganeti.Locking.Allocation is polymorphic in the types of locks
  and lock owners. 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.
  
  -}
  
  data TestOwner = TestOwner Int deriving (Ord, Eq, Show)
  
  instance Arbitrary TestOwner where
    arbitrary = TestOwner <$> choose (0, 2)
  
  data TestLock = TestBigLock
                | TestCollectionLockA
                | TestLockA Int
                | TestCollectionLockB
                | TestLockB Int
                deriving (Ord, Eq, Show, Read)
  
  instance Arbitrary TestLock where
    arbitrary =  frequency [ (1, elements [ TestBigLock
                                          , TestCollectionLockA
                                          , TestCollectionLockB
                                          ])
                           , (2, TestLockA <$> choose (0, 2))
                           , (2, TestLockB <$> choose (0, 2))
                           ]
  
  instance Lock TestLock where
    lockImplications (TestLockA _) = [TestCollectionLockA, TestBigLock]
    lockImplications (TestLockB _) = [TestCollectionLockB, TestBigLock]
    lockImplications TestBigLock = []
    lockImplications _ = [TestBigLock]
  
  {-
  
  All states of a  LockAllocation ever available outside the
  Ganeti.Locking.Allocation module must be constructed by starting
  with emptyAllocation and applying the exported functions.
  
  -}
  
  instance Arbitrary OwnerState where
    arbitrary = elements [OwnShared, OwnExclusive]
  
  instance Arbitrary a => Arbitrary (LockRequest a) where
    arbitrary = LockRequest <$> arbitrary <*> genMaybe arbitrary
  
  data UpdateRequest b a = UpdateRequest b [LockRequest a]
                         | FreeLockRequest b
                         deriving Show
  
  instance (Arbitrary a, Arbitrary b) => Arbitrary (UpdateRequest a b) where
    arbitrary =
      frequency [ (4, UpdateRequest <$> arbitrary <*> (choose (1, 4) >>= vector))
                , (1, FreeLockRequest <$> arbitrary)
                ]
  
  -- | Transform an UpdateRequest into the corresponding state transformer.
  asAllocTrans :: (Lock a, Ord b, Show b)
                => LockAllocation a b -> UpdateRequest b a -> LockAllocation a b
  asAllocTrans state (UpdateRequest owner updates) =
    fst $ updateLocks owner updates state
  asAllocTrans state (FreeLockRequest owner) = freeLocks state owner
  
  -- | Fold a sequence of requests to transform a lock allocation onto the empty
  -- allocation. As we consider all exported LockAllocation transformers, any
  -- LockAllocation definable is obtained in this way.
  foldUpdates :: (Lock a, Ord b, Show b)
              => [UpdateRequest b a] -> LockAllocation a b
  foldUpdates = foldl asAllocTrans emptyAllocation
  
  instance (Arbitrary a, Lock a, Arbitrary b, Ord b, Show b)
            => Arbitrary (LockAllocation a b) where
    arbitrary = foldUpdates <$> (choose (0, 8) >>= vector)
  
  -- | Basic property of locking: the exclusive locks of one user
  -- are disjoint from any locks of any other user.
  prop_LocksDisjoint :: Property
  prop_LocksDisjoint =
    forAll (arbitrary :: Gen (LockAllocation TestLock TestOwner)) $ \state ->
    forAll (arbitrary :: Gen TestOwner) $ \a ->
    forAll (arbitrary `suchThat` (/= a)) $ \b ->
    let aExclusive = M.keysSet . M.filter (== OwnExclusive) $ listLocks  a state
        bAll = M.keysSet $ listLocks b state
    in counterexample
       (show a ++ "'s exclusive lock" ++ " is not respected by " ++ show b)
       (S.null $ S.intersection aExclusive bAll)
  
  -- | Verify that the list of active locks indeed contains all locks that
  -- are owned by someone.
  prop_LockslistComplete :: Property
  prop_LockslistComplete =
    forAll (arbitrary :: Gen TestOwner) $ \a ->
    forAll ((arbitrary :: Gen (LockAllocation TestLock TestOwner))
            `suchThat` (not . M.null . listLocks a)) $ \state ->
    counterexample "All owned locks must be mentioned in the all-locks list" $
      let allLocks = listAllLocks state in
      all (`elem` allLocks) (M.keys $ listLocks a state)
  
  -- | Verify that the list of all locks with states is contained in the list
  -- of all locks.
  prop_LocksAllOwnersSubsetLockslist :: Property
  prop_LocksAllOwnersSubsetLockslist =
    forAll (arbitrary :: Gen (LockAllocation TestLock TestOwner)) $ \state ->
    counterexample "The list of all active locks must contain all locks mentioned\
                   \ in the locks state" $
    S.isSubsetOf (S.fromList . map fst $ listAllLocksOwners state)
        (S.fromList $ listAllLocks state)
  
  -- | Verify that all locks of all owners are mentioned in the list of all locks'
  -- owner's state.
  prop_LocksAllOwnersComplete :: Property
  prop_LocksAllOwnersComplete =
    forAll (arbitrary :: Gen TestOwner) $ \a ->
    forAll ((arbitrary :: Gen (LockAllocation TestLock TestOwner))
            `suchThat` (not . M.null . listLocks a)) $ \state ->
    counterexample "Owned locks must be mentioned in list of all locks' state" $
     let allLocksState = listAllLocksOwners state
     in flip all (M.toList $ listLocks a state) $ \(lock, ownership) ->
       elem (a, ownership) . fromMaybe [] $ lookup lock allLocksState
  
  -- | Verify that all lock owners mentioned in the list of all locks' owner's
  -- state actually own their lock.
  prop_LocksAllOwnersSound :: Property
  prop_LocksAllOwnersSound =
    forAll ((arbitrary :: Gen (LockAllocation TestLock TestOwner))
            `suchThat` (not . null . listAllLocksOwners)) $ \state ->
    counterexample "All locks mentioned in listAllLocksOwners must be owned by\
                   \ the mentioned owner" .
    flip all (listAllLocksOwners state) $ \(lock, owners) ->
    flip all owners $ \(owner, ownership) -> holdsLock owner lock ownership state
  
  -- | Verify that exclusive group locks are honored, i.e., verify that if someone
  -- holds a lock, then no one else can hold a lock on an exclusive lock on an
  -- implied lock.
  prop_LockImplicationX :: Property
  prop_LockImplicationX =
    forAll (arbitrary :: Gen (LockAllocation TestLock TestOwner)) $ \state ->
    forAll (arbitrary :: Gen TestOwner) $ \a ->
    forAll (arbitrary `suchThat` (/= a)) $ \b ->
    let bExclusive = M.keysSet . M.filter (== OwnExclusive) $ listLocks  b state
    in counterexample "Others cannot have an exclusive lock on an implied lock" .
       flip all (M.keys $ listLocks a state) $ \lock ->
       flip all (lockImplications lock) $ \impliedlock ->
       not $ S.member impliedlock bExclusive
  
  -- | Verify that shared group locks are honored, i.e., verify that if someone
  -- holds an exclusive lock, then no one else can hold any form on lock on an
  -- implied lock.
  prop_LockImplicationS :: Property
  prop_LockImplicationS =
    forAll (arbitrary :: Gen (LockAllocation TestLock TestOwner)) $ \state ->
    forAll (arbitrary :: Gen TestOwner) $ \a ->
    forAll (arbitrary `suchThat` (/= a)) $ \b ->
    let aExclusive = M.keys . M.filter (== OwnExclusive) $ listLocks  a state
        bAll = M.keysSet $ listLocks b state
    in counterexample "Others cannot hold locks implied by an exclusive lock" .
       flip all aExclusive $ \lock ->
       flip all (lockImplications lock) $ \impliedlock ->
       not $ S.member impliedlock bAll
  
  -- | Verify that locks can only be modified by updates of the owner.
  prop_LocksStable :: Property
  prop_LocksStable =
    forAll (arbitrary :: Gen (LockAllocation TestLock TestOwner)) $ \state ->
    forAll (arbitrary :: Gen TestOwner) $ \a ->
    forAll (arbitrary `suchThat` (/= a)) $ \b ->
    forAll (arbitrary :: Gen [LockRequest TestLock]) $ \request ->
    let (state', _) = updateLocks b request state
    in (listLocks a state ==? listLocks a state')
  
  -- | Verify that a given request is statisfied in list of owned locks
  requestSucceeded :: Ord a => M.Map a  OwnerState -> LockRequest a -> Bool
  requestSucceeded owned (LockRequest lock status) = M.lookup lock owned == status
  
  -- | Verify that lock updates are atomic, i.e., either we get all the required
  -- locks, or the state is completely unchanged.
  prop_LockupdateAtomic :: Property
  prop_LockupdateAtomic =
    forAll (arbitrary :: Gen (LockAllocation TestLock TestOwner)) $ \state ->
    forAll (arbitrary :: Gen TestOwner) $ \a ->
    forAll (arbitrary :: Gen [LockRequest TestLock]) $ \request ->
    let (state', result) = updateLocks a request state
    in if result == Ok S.empty
         then counterexample
              ("Update succeeded, but in final state " ++ show state'
                ++ "not all locks are as requested")
              $ let owned = listLocks a state'
                in all (requestSucceeded owned) request
         else counterexample
              ("Update failed, but state changed to " ++ show state')
              (state == state')
  
  -- | Verify that releasing a lock always succeeds.
  prop_LockReleaseSucceeds :: Property
  prop_LockReleaseSucceeds =
    forAll (arbitrary :: Gen (LockAllocation TestLock TestOwner)) $ \state ->
    forAll (arbitrary :: Gen TestOwner) $ \a ->
    forAll (arbitrary :: Gen TestLock) $ \lock ->
    let (_, result) = updateLocks a [requestRelease lock] state
    in counterexample
       ("Releasing a lock has to suceed uncondiationally, but got "
         ++ show result)
       (isOk result)
  
  -- | Verify the property that only the blocking owners prevent
  -- lock allocation. We deliberatly go for the expensive variant
  -- restraining by suchThat, as otherwise the number of cases actually
  -- covered is too small.
  prop_BlockSufficient :: Property
  prop_BlockSufficient =
    forAll (arbitrary :: Gen TestOwner) $ \a ->
    forAll (arbitrary :: Gen TestLock) $ \lock ->
    forAll (elements [ [requestShared lock]
                     , [requestExclusive lock]]) $ \request ->
    forAll ((arbitrary :: Gen (LockAllocation TestLock TestOwner))
             `suchThat` (genericResult (const False) (not . S.null)
                          . snd . updateLocks a request)) $ \state ->
    let (_, result) = updateLocks a request state
        blockedOn = genericResult (const S.empty) id result
    in  counterexample "After all blockers release, a request must succeed"
        . isOk . snd . updateLocks a request $ F.foldl freeLocks state blockedOn
  
  -- | Verify the property that every blocking owner is necessary, i.e., even
  -- if we only keep the locks of one of the blocking owners, the request still
  -- will be blocked. We deliberatly use the expensive variant of restraining
  -- to ensure good coverage. To make sure the request can always be blocked
  -- by two owners, for a shared request we request two different locks.
  prop_BlockNecessary :: Property
  prop_BlockNecessary =
    forAll (arbitrary :: Gen TestOwner) $ \a ->
    forAll (arbitrary :: Gen TestLock) $ \lock ->
    forAll (arbitrary `suchThat` (/= lock)) $ \lock' ->
    forAll (elements [ [requestShared lock, requestShared lock']
                     , [requestExclusive lock]]) $ \request ->
    forAll ((arbitrary :: Gen (LockAllocation TestLock TestOwner))
             `suchThat` (genericResult (const False) ((>= 2) . S.size)
                          . snd . updateLocks a request)) $ \state ->
    let (_, result) = updateLocks a request state
        blockers = genericResult (const S.empty) id result
    in  counterexample "Each blocker alone must block the request"
        . flip all (S.elems blockers) $ \blocker ->
          (==) (Ok $ S.singleton blocker) . snd . updateLocks a request
          . F.foldl freeLocks state
          $ S.filter (/= blocker) blockers
  
  instance J.JSON TestOwner where
    showJSON (TestOwner x) = J.showJSON x
    readJSON = (>>= return . TestOwner) . J.readJSON
  
  instance J.JSON TestLock where
    showJSON = J.showJSON . show
    readJSON = (>>= return . read) . J.readJSON
  
  -- | Verify that for LockAllocation we have readJSON . showJSON = Ok.
  prop_ReadShow :: Property
  prop_ReadShow =
    forAll (arbitrary :: Gen (LockAllocation TestLock TestOwner)) $ \state ->
    J.readJSON (J.showJSON state) ==? J.Ok state
  
  -- | Verify that the list of lock owners is complete.
  prop_OwnerComplete :: Property
  prop_OwnerComplete =
    forAll (arbitrary :: Gen (LockAllocation TestLock TestOwner)) $ \state ->
    foldl freeLocks state (lockOwners state) ==? emptyAllocation
  
  -- | Verify that each owner actually owns a lock.
  prop_OwnerSound :: Property
  prop_OwnerSound =
    forAll ((arbitrary :: Gen (LockAllocation TestLock TestOwner))
            `suchThat` (not . null . lockOwners)) $ \state ->
    counterexample "All subjects listed as owners must own at least one lock"
    . flip all (lockOwners state) $ \owner ->
    not . M.null $ listLocks owner state
  
  -- | Verify that for LockRequest we have readJSON . showJSON = Ok.
  prop_ReadShowRequest :: Property
  prop_ReadShowRequest =
    forAll (arbitrary :: Gen (LockRequest TestLock)) $ \state ->
    J.readJSON (J.showJSON state) ==? J.Ok state
  
  
  testSuite "Locking/Allocation"
   [ 'prop_LocksDisjoint
   , 'prop_LockslistComplete
   , 'prop_LocksAllOwnersSubsetLockslist
   , 'prop_LocksAllOwnersComplete
   , 'prop_LocksAllOwnersSound
   , 'prop_LockImplicationX
   , 'prop_LockImplicationS
   , 'prop_LocksStable
   , 'prop_LockupdateAtomic
   , 'prop_LockReleaseSucceeds
   , 'prop_BlockSufficient
   , 'prop_BlockNecessary
   , 'prop_ReadShow
   , 'prop_OwnerComplete
   , 'prop_OwnerSound
   , 'prop_ReadShowRequest
   ]
  