{-# 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 Prelude ()
import Ganeti.Prelude

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
 ]