{-# LANGUAGE OverloadedStrings, RecordWildCards, GeneralizedNewtypeDeriving, DeriveFunctor #-}
module PayChanSpec where

import           PaymentChannel.Test

import qualified Network.Haskoin.Transaction    as HT
import qualified Network.Haskoin.Crypto         as HC
import qualified Network.Haskoin.Test           as HC
import qualified Network.Haskoin.Constants      as HCC
import qualified Data.Aeson                     as JSON
import qualified Data.Serialize                 as Bin

import Test.QuickCheck
import Test.QuickCheck.Monadic              (monadic, run , assert)
import Test.QuickCheck.Property             (Property)
import Control.Monad.Identity (Identity(Identity))
import Test.Hspec

import Debug.Trace
{-# ANN module ("HLint: ignore Redundant if"::String) #-}


newtype TestM a = TestM { runTestId :: Identity a }
    deriving (Functor, Applicative, Monad)

instance MonadTime TestM where
    currentTime = return nowishTimestamp

runTestM :: forall c. TestM c -> c
runTestM = getIt . runTestId
    where getIt (Identity a) = a

testAddr :: HC.Address
testAddr = if HCC.getNetwork == HCC.prodnet
    then "14wjVnwHwMAXDr6h5Fw38shCWUB6RSEa63"
    else "n2eMqTT929pb1RDNuqEnxdaLau1rxy3efi"

recvSettleAddr :: HC.Address
recvSettleAddr = testAddr

main :: IO ()
main = hspec spec

spec :: Spec
spec = do
    paymentSpec
    conversionSpec

paymentSpec :: Spec
paymentSpec =
  describe "Payment" $
    around withArbChanResult $ do
      describe "Settlement tx" $ do
        it "client change output amount equals funding value minus sum of payment values" $ \res -> do
          let (changeAmount, fundValMinusPaySum, _) = runTestM $ checkSenderValue res
          changeAmount `shouldBe` fundValMinusPaySum
        it "receiver output amount equals sum of payment values" $ \res -> do
          let (recvOutVal, paySumVal, _) = runTestM $ checkReceiverValue res
          recvOutVal `shouldBe` paySumVal
        it "always has at least one output" $ \res ->
          runTestM (minOneOutput res) `shouldBe` True
      describe "State" $ do
        it "Sender/receiver match"
          checkSendRecvStateMatch
        it "Sent amounts == received amounts"
          recvSendAmountsMatch
      describe "Channel close" $
        it "Can produce & accept arbitrary closing payment with sane fee" $ \res -> do
          HC.ArbitraryAddress arbAddr <- generate arbitrary
          txFee <- fromIntegral <$> generate (choose (0 :: Word64, 10000))
          let closedStateE = createAcceptClosingPayment arbAddr (txFee :: SatoshisPerByte) res
          closedStateE `shouldSatisfy` isRight
          let Right closedState = closedStateE
          HC.ArbitraryAddress arbServerAddr <- generate arbitrary
--          HC.ArbitraryPrvKeyC prvKey <- generate arbitrary
          let settleTxE = runDummy $ closedGetSettlementTx closedState arbServerAddr DropDust
          settleTxE `shouldSatisfy` isRight

conversionSpec :: Spec
conversionSpec = do
  describe "Conversion works for" $
    it "RedeemScript" $ generate arbitrary >>=
      redeemScriptConversion
  describe "Serialization works for" $ do
    describe "JSON" $ do
      it "Payment" $ generate arbitrary >>=
        (jsonSerDeser :: Payment BtcSig -> IO ())
      it "ServerPayChan" $ generate arbitrary >>=
        (jsonSerDeser :: ServerPayChanX -> IO ())
    describe "Binary" $ do
      it "Payment" $ generate arbitrary >>=
        (binSerDeser  :: Payment BtcSig -> IO ())
      it "PayChanState" $ generate arbitrary >>=
        (binSerDeser  :: PayChanState BtcSig -> IO ())
      it "ChanParams" $ generate arbitrary >>=
        (binSerDeser  :: ChanParams -> IO ())

withArbChanResult :: (ChannelPairResult -> IO ()) -> IO ()
withArbChanResult f = do
    arbPair <- generate arbitrary
    amtLst  <- generate arbitrary
    runChanPair arbPair amtLst >>= f

redeemScriptConversion :: ChanParams -> IO ()
redeemScriptConversion cp =
    fromRedeemScript (getRedeemScript cp) `shouldBe` Right cp

checkSenderValue :: ChannelPairResult -> TestM (BtcAmount, BtcAmount, HT.Tx)
checkSenderValue cpr@ChannelPairResult{..} = do
    settleTx <- mkSettleTx cpr
    let clientChangeOutIndex = indexOf settleTx (fundingAddress resSendChan)
        clientChangeAmount = maybe 0 (HT.outValue . (HT.txOut settleTx !!)) clientChangeOutIndex
    -- Check that the client change amount in the settlement transaction equals the
    --  channel funding amount minus the sum of all payment amounts.
    let fundingVal = fundingValue $ pcsPayment (getChanState resRecvChan)
        fundValMinusPaym = fundingVal - fromIntegral (sum resSentAmounts)
    return (fromIntegral clientChangeAmount, fundValMinusPaym, settleTx)

checkReceiverValue :: ChannelPairResult -> TestM (BtcAmount, BtcAmount, HT.Tx)
checkReceiverValue cpr@ChannelPairResult{..} = do
    settleTx <- mkSettleTx cpr
    let recvOutIndex = indexOf settleTx recvSettleAddr
        recvAmount = maybe 0 (HT.outValue . (HT.txOut settleTx !!)) recvOutIndex
    -- Check receiver amount in settlement transaction with zero fee equals sum
    -- of all payments.
    return (fromIntegral recvAmount :: BtcAmount, fromIntegral (sum resRecvdAmounts), settleTx)

minOneOutput :: ChannelPairResult -> TestM Bool
minOneOutput cpr = not . null . HT.txOut <$> mkSettleTx cpr

checkSendRecvStateMatch :: ChannelPairResult -> IO ()
checkSendRecvStateMatch ChannelPairResult{..} =
    getChanState resSendChan `shouldBe` getChanState resRecvChan

recvSendAmountsMatch :: ChannelPairResult -> IO ()
recvSendAmountsMatch ChannelPairResult{..} =
    resSentAmounts `shouldBe` resRecvdAmounts



jsonSerDeser :: (Show a, Eq a, JSON.FromJSON a, JSON.ToJSON a) => a -> IO ()
jsonSerDeser fp =
    JSON.decode (JSON.encode fp) `shouldBe` Just fp

binSerDeser :: (Typeable a, Show a, Eq a, Bin.Serialize a) => a -> IO ()
binSerDeser fp =
    deserEither (Bin.encode fp) `shouldBe` Right fp


testPaymentSessionM ::
    (ChannelPairResult -> TestM Bool)
    -> ArbChannelPair
    -> [BtcAmount]
    -> Property
testPaymentSessionM testFunc arbChanPair payLst =
    monadic runTestM $
        run (runChanPair arbChanPair payLst) >>= run . testFunc >>= assert


indexOf :: HT.Tx -> HC.Address -> Maybe Int
indexOf tx addr = listToMaybe $ catMaybes $ zipWith f [0..] (HT.txOut tx)
    where f idx out =
            if HT.scriptOutput out == addressToScriptPubKeyBS addr
                then Just idx
                else Nothing

mkSettleTx :: Monad m =>
            ChannelPairResult -> m Tx
mkSettleTx ChannelPairResult{..} = do
    let prvKey = testPrvKeyC $ recvPrvKey resInitPair
    let settleTxE = runSimple prvKey $ getSettlementBitcoinTx
            resRecvChan recvSettleAddr
            (SatoshisPerByte 0) KeepDust
    return $ either (error . show) toHaskoinTx settleTxE