# LANGUAGE RecordWildCards #
# LANGUAGE TupleSections    #

-- | Specification for transaction-related core functions
-- (Pos.Chain.Txp.Core).

module Test.Pos.Chain.Txp.CoreSpec
       ( spec
       ) where

import           Universum

import           Control.Lens (each)
import qualified Data.HashMap.Strict as HM
import           Data.List (elemIndex, (\\))
import qualified Data.List.NonEmpty as NE
import           Test.Hspec (Spec, describe)
import           Test.Hspec.QuickCheck (prop)
import           Test.QuickCheck (NonNegative (..), Positive (..), Property,
                     arbitrary, forAll, resize, shuffle, vectorOf, (.&.),
                     (===))
import           Test.QuickCheck.Gen (Gen)

import           Pos.Chain.Txp (Tx (..), TxIn (..), TxOut (..),
                     TxValidationRules (..), checkTx, topsortTxs)
import           Pos.Core (mkCoin)
import           Pos.Core.Attributes (mkAttributes)
import           Pos.Core.Slotting (EpochIndex (..))
import           Pos.Crypto (hash, whData, withHash)
import           Pos.Util (_neHead)

import           Test.Pos.Chain.Txp.Arbitrary (genAddressBloatedTx)
import           Test.Pos.Util.QuickCheck.Arbitrary (sublistN)
import           Test.Pos.Util.QuickCheck.Property (qcIsLeft, qcIsRight)


spec :: Spec
spec = describe "Txp.Core" $ do
    describe "checkTx" $ do
        prop description_checkTxGood (checkTxGood True)
        prop description_checkTxBad checkTxBad
        prop description_checkTxBloatedBeforeEpoch $
            forAll genAddressBloatedTx $ \ blTx ->
            checkTxGood True blTx beforeCutoffEpochIndex0
        prop description_checkTxBloatedBeforeEpoch $
            forAll genAddressBloatedTx $ \ blTx ->
            checkTxGood True blTx beforeCutoffEpochIndex1
        prop description_checkTxBloatedAfterEpoch $
            forAll genAddressBloatedTx $ \ blTx ->
            checkTxGood False blTx afterCutoffEpochIndex0
        prop description_checkTxBloatedAfterEpoch $
            forAll genAddressBloatedTx $ \ blTx ->
            checkTxGood False blTx afterCutoffEpochIndex1
    describe "topsortTxs" $ do
        prop "doesn't change the random set of transactions" $
            forAll (resize 10 $ arbitrary) $ \(NonNegative l) ->
            forAll (vectorOf l (txGen 10)) $ \txs ->
            let withHashTxs = map withHash txs in
            (sort <$> topsortTxs identity withHashTxs) === Just (sort withHashTxs)
        prop "doesn't change acyclic set of transactions" $
            forAll (txAcyclicGen False 20) $ \(txs,_) ->
            forAll (shuffle $ map withHash txs) $ \shuffled ->
            (sort <$> topsortTxs identity shuffled) === Just (sort $ map withHash txs)
        prop "graph generator does not produce loops" $
            forAll (txAcyclicGen False 20) $ \(txs,_) ->
            forAll (shuffle $ map withHash txs) $ \shuffled ->
            isJust $ topsortTxs identity shuffled
        prop "does correct topsort on bamboo" $ testTopsort True
        prop "does correct topsort on arbitrary acyclic graph" $ testTopsort False
  where
    description_checkTxGood =
        "creates Tx if arguments are taken from valid Tx"
    description_checkTxBad =
        "doesn't create Tx with non-positive coins in outputs"
    description_checkTxBloatedBeforeEpoch =
        "creates a bloated Tx via Attributes AddrAttributes before cutoff epoch"
    description_checkTxBloatedAfterEpoch =
        "creates a bloated Tx via Attributes AddrAttributes after cutoff epoch"

checkTxGood :: Bool -> Tx -> TxValidationRules -> Property
checkTxGood isGood tx txValRules = checker result
  where
    result = checkTx txValRules tx
    checker = if isGood
                 then qcIsRight
                 else qcIsLeft

checkTxBad :: Tx -> TxValidationRules -> Bool
checkTxBad UnsafeTx {..} txValRules =
    all (\outs -> isLeft $ checkTx txValRules (UnsafeTx _txInputs outs _txAttributes)) badOutputs
  where
    invalidateOut :: TxOut -> TxOut
    invalidateOut out = out {txOutValue = mkCoin 0}
    badOutputs :: [NonEmpty TxOut]
    badOutputs = [ _txOutputs & _neHead %~ invalidateOut
                 , _txOutputs & each %~ invalidateOut
                 ]

testTopsort :: Bool -> Property
testTopsort isBamboo =
    forAll (txAcyclicGen isBamboo 40) $ \(txs,reach) ->
    forAll (shuffle txs) $ \shuffled ->
    let reachables :: [(Tx,Tx)]
        reachables = [(from,to) | (to,froms) <- HM.toList reach, from <- froms]
        topsorted = map whData <$> topsortTxs identity (map withHash shuffled)
        reaches :: (Tx,Tx) -> Bool
        reaches (from,to) =
            let fromI = elemIndex from =<< topsorted
                toI = elemIndex to =<< topsorted
            in Just True == ((<=) <$> fromI <*> toI)
    in isJust topsorted .&. all reaches reachables

-- | Produces acyclic oriented graph of transactions. It's
-- connected. Signatures are faked and thus fail to
-- verify. Transaction balance is bad too (input can be less than
-- output). These properties are not needed for topsort test. It also
  returns reachability map as the second argument ( for every key
  elems from which we can reach key ) .
txAcyclicGen :: Bool -> Int -> Gen ([Tx], HM.HashMap Tx [Tx])
txAcyclicGen _ 0 = pure ([], HM.empty)
txAcyclicGen isBamboo size = do
    initVertices <-
        replicateM (bool (max 1 $ size `div` 4) 1 isBamboo) $ txGen some'
    let outputs =
            concatMap (\tx -> map (tx,) [0..length (_txOutputs tx) - 1])
                      initVertices
        reachable = HM.fromList $ map (\v -> (v, [v])) initVertices
    continueGraph initVertices outputs reachable $ size - length initVertices
  where
    some' = bool 4 1 isBamboo
    continueGraph
        :: [Tx]
        -> [(Tx, Int)]
        -> HM.HashMap Tx [Tx]
        -> Int
        -> Gen ([Tx], HM.HashMap Tx [Tx])
    continueGraph vertices _ reachable 0 = pure (vertices, reachable)
    continueGraph vertices unusedUtxo reachable k
      | null unusedUtxo = pure (vertices, reachable)
      | otherwise =  do
        -- how many nodes to connect to (how many utxo to use)
        depsN <-
            max 1 . min (bool (min 3 $ length unusedUtxo) 1 isBamboo) <$> arbitrary
        chosenUtxo <- NE.fromList <$> sublistN depsN unusedUtxo
        -- grab some inputs
        let inputs = map (\(h,i) -> TxInUtxo (hash h) (fromIntegral i)) chosenUtxo
        (Positive outputsN) <- resize some' arbitrary
        -- gen some outputs
        outputs <- NE.fromList <$> replicateM outputsN (TxOut <$> arbitrary <*> arbitrary)
  calculate new utxo & add vertex
        let tx = UnsafeTx inputs outputs $ mkAttributes ()
            producedUtxo = map (tx,) $ [0..(length outputs) - 1]
            newVertices = tx : vertices
            newUtxo = (unusedUtxo \\ toList chosenUtxo) ++ producedUtxo
            newReachableV = tx : concat (mapMaybe (\(x,_) -> HM.lookup x reachable)
                                         $ toList chosenUtxo)
            newReachable = HM.insert tx newReachableV reachable
        continueGraph newVertices newUtxo newReachable (k - 1)

-- | Primitive transaction generator with restriction on
-- inputs/outputs size
txGen :: Int -> Gen Tx
txGen size = do
    (Positive inputsN) <- resize size arbitrary
    (Positive outputsN) <- resize size arbitrary
    inputs <- NE.fromList <$> (replicateM inputsN $ (\h -> TxInUtxo h 0) <$> arbitrary)
    outputs <-
        NE.fromList <$> (replicateM outputsN $ TxOut <$> arbitrary <*> arbitrary)
    let tx = UnsafeTx inputs outputs (mkAttributes ())
  FIXME ca n't we convince ourselves that the Tx we made is valid ?
    txValRules <- arbitrary
    case checkTx txValRules tx of
        Left e   -> error $ "txGen: something went wrong: " <> e
        Right () -> pure tx

-- Values that test when to enforce the
-- Tx validation rules.

beforeCutoffEpochIndex0 :: TxValidationRules
beforeCutoffEpochIndex0 = TxValidationRules
    (EpochIndex 100)
    (EpochIndex 99)
    1
    1

beforeCutoffEpochIndex1 :: TxValidationRules
beforeCutoffEpochIndex1 = TxValidationRules
    (EpochIndex 9878)
    (EpochIndex 9)
    10000
    10000

afterCutoffEpochIndex0 :: TxValidationRules
afterCutoffEpochIndex0 = TxValidationRules
    (EpochIndex 101)
    (EpochIndex 102)
    128
    128

afterCutoffEpochIndex1 :: TxValidationRules
afterCutoffEpochIndex1 = TxValidationRules
    (EpochIndex 47)
    (EpochIndex 7002)
    128
    128

 | Specification for transaction-related core functions
 (Pos.Chain.Txp.Core).
 | Produces acyclic oriented graph of transactions. It's
 connected. Signatures are faked and thus fail to
 verify. Transaction balance is bad too (input can be less than
 output). These properties are not needed for topsort test. It also
 how many nodes to connect to (how many utxo to use)
 grab some inputs
 gen some outputs
 | Primitive transaction generator with restriction on
 inputs/outputs size
 Values that test when to enforce the
 Tx validation rules.
# LANGUAGE RecordWildCards #
# LANGUAGE TupleSections    #


module Test.Pos.Chain.Txp.CoreSpec
       ( spec
       ) where

import           Universum

import           Control.Lens (each)
import qualified Data.HashMap.Strict as HM
import           Data.List (elemIndex, (\\))
import qualified Data.List.NonEmpty as NE
import           Test.Hspec (Spec, describe)
import           Test.Hspec.QuickCheck (prop)
import           Test.QuickCheck (NonNegative (..), Positive (..), Property,
                     arbitrary, forAll, resize, shuffle, vectorOf, (.&.),
                     (===))
import           Test.QuickCheck.Gen (Gen)

import           Pos.Chain.Txp (Tx (..), TxIn (..), TxOut (..),
                     TxValidationRules (..), checkTx, topsortTxs)
import           Pos.Core (mkCoin)
import           Pos.Core.Attributes (mkAttributes)
import           Pos.Core.Slotting (EpochIndex (..))
import           Pos.Crypto (hash, whData, withHash)
import           Pos.Util (_neHead)

import           Test.Pos.Chain.Txp.Arbitrary (genAddressBloatedTx)
import           Test.Pos.Util.QuickCheck.Arbitrary (sublistN)
import           Test.Pos.Util.QuickCheck.Property (qcIsLeft, qcIsRight)


spec :: Spec
spec = describe "Txp.Core" $ do
    describe "checkTx" $ do
        prop description_checkTxGood (checkTxGood True)
        prop description_checkTxBad checkTxBad
        prop description_checkTxBloatedBeforeEpoch $
            forAll genAddressBloatedTx $ \ blTx ->
            checkTxGood True blTx beforeCutoffEpochIndex0
        prop description_checkTxBloatedBeforeEpoch $
            forAll genAddressBloatedTx $ \ blTx ->
            checkTxGood True blTx beforeCutoffEpochIndex1
        prop description_checkTxBloatedAfterEpoch $
            forAll genAddressBloatedTx $ \ blTx ->
            checkTxGood False blTx afterCutoffEpochIndex0
        prop description_checkTxBloatedAfterEpoch $
            forAll genAddressBloatedTx $ \ blTx ->
            checkTxGood False blTx afterCutoffEpochIndex1
    describe "topsortTxs" $ do
        prop "doesn't change the random set of transactions" $
            forAll (resize 10 $ arbitrary) $ \(NonNegative l) ->
            forAll (vectorOf l (txGen 10)) $ \txs ->
            let withHashTxs = map withHash txs in
            (sort <$> topsortTxs identity withHashTxs) === Just (sort withHashTxs)
        prop "doesn't change acyclic set of transactions" $
            forAll (txAcyclicGen False 20) $ \(txs,_) ->
            forAll (shuffle $ map withHash txs) $ \shuffled ->
            (sort <$> topsortTxs identity shuffled) === Just (sort $ map withHash txs)
        prop "graph generator does not produce loops" $
            forAll (txAcyclicGen False 20) $ \(txs,_) ->
            forAll (shuffle $ map withHash txs) $ \shuffled ->
            isJust $ topsortTxs identity shuffled
        prop "does correct topsort on bamboo" $ testTopsort True
        prop "does correct topsort on arbitrary acyclic graph" $ testTopsort False
  where
    description_checkTxGood =
        "creates Tx if arguments are taken from valid Tx"
    description_checkTxBad =
        "doesn't create Tx with non-positive coins in outputs"
    description_checkTxBloatedBeforeEpoch =
        "creates a bloated Tx via Attributes AddrAttributes before cutoff epoch"
    description_checkTxBloatedAfterEpoch =
        "creates a bloated Tx via Attributes AddrAttributes after cutoff epoch"

checkTxGood :: Bool -> Tx -> TxValidationRules -> Property
checkTxGood isGood tx txValRules = checker result
  where
    result = checkTx txValRules tx
    checker = if isGood
                 then qcIsRight
                 else qcIsLeft

checkTxBad :: Tx -> TxValidationRules -> Bool
checkTxBad UnsafeTx {..} txValRules =
    all (\outs -> isLeft $ checkTx txValRules (UnsafeTx _txInputs outs _txAttributes)) badOutputs
  where
    invalidateOut :: TxOut -> TxOut
    invalidateOut out = out {txOutValue = mkCoin 0}
    badOutputs :: [NonEmpty TxOut]
    badOutputs = [ _txOutputs & _neHead %~ invalidateOut
                 , _txOutputs & each %~ invalidateOut
                 ]

testTopsort :: Bool -> Property
testTopsort isBamboo =
    forAll (txAcyclicGen isBamboo 40) $ \(txs,reach) ->
    forAll (shuffle txs) $ \shuffled ->
    let reachables :: [(Tx,Tx)]
        reachables = [(from,to) | (to,froms) <- HM.toList reach, from <- froms]
        topsorted = map whData <$> topsortTxs identity (map withHash shuffled)
        reaches :: (Tx,Tx) -> Bool
        reaches (from,to) =
            let fromI = elemIndex from =<< topsorted
                toI = elemIndex to =<< topsorted
            in Just True == ((<=) <$> fromI <*> toI)
    in isJust topsorted .&. all reaches reachables

  returns reachability map as the second argument ( for every key
  elems from which we can reach key ) .
txAcyclicGen :: Bool -> Int -> Gen ([Tx], HM.HashMap Tx [Tx])
txAcyclicGen _ 0 = pure ([], HM.empty)
txAcyclicGen isBamboo size = do
    initVertices <-
        replicateM (bool (max 1 $ size `div` 4) 1 isBamboo) $ txGen some'
    let outputs =
            concatMap (\tx -> map (tx,) [0..length (_txOutputs tx) - 1])
                      initVertices
        reachable = HM.fromList $ map (\v -> (v, [v])) initVertices
    continueGraph initVertices outputs reachable $ size - length initVertices
  where
    some' = bool 4 1 isBamboo
    continueGraph
        :: [Tx]
        -> [(Tx, Int)]
        -> HM.HashMap Tx [Tx]
        -> Int
        -> Gen ([Tx], HM.HashMap Tx [Tx])
    continueGraph vertices _ reachable 0 = pure (vertices, reachable)
    continueGraph vertices unusedUtxo reachable k
      | null unusedUtxo = pure (vertices, reachable)
      | otherwise =  do
        depsN <-
            max 1 . min (bool (min 3 $ length unusedUtxo) 1 isBamboo) <$> arbitrary
        chosenUtxo <- NE.fromList <$> sublistN depsN unusedUtxo
        let inputs = map (\(h,i) -> TxInUtxo (hash h) (fromIntegral i)) chosenUtxo
        (Positive outputsN) <- resize some' arbitrary
        outputs <- NE.fromList <$> replicateM outputsN (TxOut <$> arbitrary <*> arbitrary)
  calculate new utxo & add vertex
        let tx = UnsafeTx inputs outputs $ mkAttributes ()
            producedUtxo = map (tx,) $ [0..(length outputs) - 1]
            newVertices = tx : vertices
            newUtxo = (unusedUtxo \\ toList chosenUtxo) ++ producedUtxo
            newReachableV = tx : concat (mapMaybe (\(x,_) -> HM.lookup x reachable)
                                         $ toList chosenUtxo)
            newReachable = HM.insert tx newReachableV reachable
        continueGraph newVertices newUtxo newReachable (k - 1)

txGen :: Int -> Gen Tx
txGen size = do
    (Positive inputsN) <- resize size arbitrary
    (Positive outputsN) <- resize size arbitrary
    inputs <- NE.fromList <$> (replicateM inputsN $ (\h -> TxInUtxo h 0) <$> arbitrary)
    outputs <-
        NE.fromList <$> (replicateM outputsN $ TxOut <$> arbitrary <*> arbitrary)
    let tx = UnsafeTx inputs outputs (mkAttributes ())
  FIXME ca n't we convince ourselves that the Tx we made is valid ?
    txValRules <- arbitrary
    case checkTx txValRules tx of
        Left e   -> error $ "txGen: something went wrong: " <> e
        Right () -> pure tx


beforeCutoffEpochIndex0 :: TxValidationRules
beforeCutoffEpochIndex0 = TxValidationRules
    (EpochIndex 100)
    (EpochIndex 99)
    1
    1

beforeCutoffEpochIndex1 :: TxValidationRules
beforeCutoffEpochIndex1 = TxValidationRules
    (EpochIndex 9878)
    (EpochIndex 9)
    10000
    10000

afterCutoffEpochIndex0 :: TxValidationRules
afterCutoffEpochIndex0 = TxValidationRules
    (EpochIndex 101)
    (EpochIndex 102)
    128
    128

afterCutoffEpochIndex1 :: TxValidationRules
afterCutoffEpochIndex1 = TxValidationRules
    (EpochIndex 47)
    (EpochIndex 7002)
    128
    128
