{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, DeriveGeneric, DeriveAnyClass #-}
module PaymentChannel.Test
( module PaymentChannel.Test
, module X
)   where

import PaymentChannel           as X
import PaymentChannel.Util      as X
import PaymentChannel.Internal.Receiver.Types as X
import qualified RBPCP.Types as RBPCP

import qualified Network.Haskoin.Crypto as HC
import qualified Network.Haskoin.Transaction as HT
import qualified Network.Haskoin.Script as HS
import qualified Data.ByteString.Char8        as C8
import qualified Data.Serialize         as Bin
import           Network.Haskoin.Test
import            Data.Time.Clock.POSIX
import           Data.Time.Clock                 (UTCTime(..))
import           Data.Time.Calendar              (Day(..))
import           Control.Monad                   (foldM)

import Test.QuickCheck

import Debug.Trace
debugEnable = False
debugTrace str a = if debugEnable then trace str a else a

maxCoins :: Integer
maxCoins = fromIntegral (maxBound :: BtcAmount)

mIN_CHANNEL_SIZE :: BtcAmount
mIN_CHANNEL_SIZE = testDustLimit * 2

testDustLimit :: BtcAmount
testDustLimit = 6200

testSettlePeriod :: Hour
testSettlePeriod = MkHour 12

testMinDuration :: Hour
testMinDuration = MkHour 48

mkTestServerConf :: BtcAmount -> ServerSettings
mkTestServerConf = ServerSettings
    testDustLimit testSettlePeriod testMinDuration


data ArbChannelPair = ArbChannelPair
    { sendChan          :: ClientPayChan
    , recvChan          :: ServerPayChanX
    , initPayAmount     :: BtcAmount
    , initRecvAmount    :: BtcAmount
    , initPayment       :: SignedPayment
    , recvPrvKey        :: TestRecvKey
    } deriving (Generic, NFData)

data TestRecvKey = TestRecvKey RootPrv (External ChildPair)
      deriving (Generic, NFData)

testPrvKeyC :: TestRecvKey -> HC.PrvKeyC
testPrvKeyC (TestRecvKey _ pair) = getKey pair

data ChannelPairResult = ChannelPairResult
    { resInitPair       :: ArbChannelPair
    , resSendChan       :: ClientPayChan
    , resRecvChan       :: ServerPayChanX
    , resSentAmounts    :: [BtcAmount]
    , resRecvdAmounts   :: [BtcAmount]
    , resPayList        :: [SignedPayment]
    } deriving (Generic, NFData, Show)

instance Show ArbChannelPair where
    show (ArbChannelPair spc rpc _ _ _ _) =
        "SendState: " ++ show spc ++ "\n" ++
        "RecvState: " ++ show rpc

instance Arbitrary ArbChannelPair where
    arbitrary = fmap fst mkChanPair

instance Arbitrary ClientPayChan where
    arbitrary = fmap (sendChan . fst) mkChanPair

instance Arbitrary ServerPayChanX where
    arbitrary = fmap (recvChan . fst) mkChanPair

instance Arbitrary (PayChanState BtcSig) where
    arbitrary = fmap rpcState (arbitrary :: Gen ServerPayChanX)

instance Arbitrary ChanParams where
    arbitrary = fmap fst mkChanParams

instance Arbitrary BtcAmount where
    arbitrary = fromIntegral <$> choose (0, maxCoins)

instance Arbitrary NonDustyAmount where
    arbitrary = arbitraryNonDusty 0

arbitraryNonDusty :: BtcAmount -> Gen NonDustyAmount
arbitraryNonDusty extraVal = do
  val <- fromIntegral <$> choose (fromIntegral $ testDustLimit + extraVal, maxCoins)
  either (\e -> error $ "Dusty amount: " ++ show val) return $
      runConfM (mkTestServerConf 0) $ mkNonDusty (val :: BtcAmount)

genLockTimeDate
    :: ServerSettings
    -> UTCTime          -- ^ Now-timestamp
    -> Hour             -- ^ Maximum duration
    -> Gen LockTimeDate
genLockTimeDate ServerSettings{..} now maxDuration = do
    let leeway = 6 :: Hour
        maxTs = fromIntegral (maxBound :: Word32)
        startTs = (round $ utcTimeToPOSIXSeconds now :: Integer) +
                    toSeconds (serverConfSettlePeriod + serverConfMinDuration + leeway)
    timestamp <- choose (startTs, min (startTs + toSeconds maxDuration) maxTs)
    either (const $ error $ "genLockTimeDate: bad logic: " ++ show timestamp) return $
        parseLockTime (fromIntegral timestamp)


newtype NonZeroBitcoinAmount = NonZeroBitcoinAmount { getAmount :: BtcAmount }

instance Arbitrary NonZeroBitcoinAmount where
    arbitrary = (NonZeroBitcoinAmount . fromIntegral) <$>
        choose (1, maxCoins)

instance Arbitrary (Payment BtcSig) where
    arbitrary = snd <$> mkChanPair

-- -- Soft child keys (keys derivable from an XPubKey) have an index of less than 0x80000000
--instance Arbitrary KeyDeriveIndex where
--    arbitrary =
--        fromMaybe (error "Bad key index") . mkKeyIndex <$> choose (0, 0x80000000 - 1)

instance MonadTime Gen where
    currentTime = return nowishTimestamp


instance Arbitrary RootPrv where
     arbitrary = createRootPrv <$> arbitrary

instance Arbitrary ByteString where
    arbitrary = do
        len <- choose (0,32)
        c8Lst <- vector len
        return $ C8.pack c8Lst


toInitResult :: ArbChannelPair -> ChannelPairResult
toInitResult initPair@(ArbChannelPair spc rpc payAmt rcvAmt pay _) =
    ChannelPairResult initPair spc rpc [payAmt] [rcvAmt] [pay]


-- |Fold a payment of specified value into a 'ChannelPairResult'
doPayment :: MonadTime m => ChannelPairResult -> BtcAmount -> m ChannelPairResult
doPayment (ChannelPairResult initPair spc rpc sendList recvList payLst) amount = do
    let (newSpc, pmn, amountSent) = createPaymentCapped spc (Capped amount)
    eitherRpc <- ("doPayment send: " ++ show amountSent) `debugTrace` acceptPayment (toPaymentData pmn) rpc
    case eitherRpc of
        Left e -> error (show e)
        Right (newRpc, recvAmount) -> return $ ("doPayment recv: " ++ show recvAmount) `debugTrace`
            ChannelPairResult initPair newSpc newRpc
                (amountSent : sendList)
                (recvAmount : recvList)
                (pmn : payLst)

runChanPair :: MonadTime m => ArbChannelPair -> [BtcAmount] -> m ChannelPairResult
runChanPair chanPair paymentAmountList =
    ("runChanPair lst: " ++ show paymentAmountList) `debugTrace`
    foldM doPayment (toInitResult chanPair) paymentAmountList

mkChanParams :: Gen (ChanParams, (HC.PrvKeyC, TestRecvKey))
mkChanParams = arbitrary >>= fromRecvRootKey

fromRecvRootKey :: RootPrv -> Gen (ChanParams, (HC.PrvKeyC, TestRecvKey))
fromRecvRootKey recvRoot = do
    -- sender key pair
    ArbitraryPubKeyC sendPriv sendPK <- arbitrary
    -- receiver key pair
    ArbitrarySoftPath arbPath <- arbitrary
    let childPair = mkChild recvRoot arbPath :: External ChildPair
        recvPK    = getKey childPair
    -- TODO: Use a future expiration date for now
    lockTime <- either (error "Bad lockTime") id . parseLockTime <$> choose (1795556940, maxBound)
    return (ChanParams
                (MkSendPubKey sendPK) (MkRecvPubKey $ HC.xPubKey recvPK) lockTime,
           (sendPriv, TestRecvKey recvRoot childPair ))

mkChanPair :: Gen (ArbChannelPair, SignedPayment)
mkChanPair = arbitrary >>= mkChanPairInitAmount

mkChanPairInitAmount :: BtcAmount -> Gen (ArbChannelPair, SignedPayment)
mkChanPairInitAmount initPayAmount = do
    let testServerConf = mkTestServerConf initPayAmount
    (cp, (sendPriv, recvKey@(TestRecvKey _ childPair))) <- mkChanParams
    fundingVal <- arbitraryNonDusty $ max mIN_CHANNEL_SIZE (initPayAmount + testDustLimit)
    (vout,tx)  <- arbitraryFundingTx cp (nonDusty fundingVal)
    let fundInfo = testRbpcpFundingInfo testServerConf cp initPayAmount
        sendChanE = channelWithInitialPayment sendPriv (cpLockTime cp) (tx,vout) fundInfo
    let (sendChan,initPayment) = either (error . show) id sendChanE

    recvChanE <- channelFromInitialPayment testServerConf tx (toPaymentData initPayment)
    let mkExtRPC chan = fromMaybe (error $ "mkExtendedKeyRPC failed. " ++ show (chan,childPair))
                                  $ mkExtendedKeyRPC chan (fromExternalPair childPair)
    case recvChanE of
        Left e -> error (show e)
        Right recvChan -> return
                 ( ArbChannelPair
                    sendChan (mkExtRPC recvChan) initPayAmount initPayAmount initPayment recvKey
                 , initPayment)

testRbpcpFundingInfo ::
       ServerSettings
    -> ChanParams
    -> BtcAmount          -- ^ Open price
    -> RBPCP.FundingInfo
testRbpcpFundingInfo ServerSettings{..} cp openPrice =
    RBPCP.FundingInfo
        { RBPCP.fundingInfoServerPubkey               = RBPCP.Server . getPubKey . getRecvPubKey $ cp
        , RBPCP.fundingInfoDustLimit                  = fromIntegral testDustLimit
        , RBPCP.fundingInfoFundingAddressCopy         = getFundingAddress cp
        , RBPCP.fundingInfoOpenPrice                  = fromIntegral openPrice
        , RBPCP.fundingInfoFundingTxMinConf        = 0
        , RBPCP.fundingInfoSettlementPeriodHours    = fromIntegral serverConfSettlePeriod
        , RBPCP.fundingInfoMinDurationHours         = fromIntegral serverConfMinDuration
        }

-- Arbitrary range
--instance Arbitrary (BtcAmount,BtcAmount) where
--    arbitrary = do
--        arbMin <- arbitrary
--        arbMax <- choose (fromIntegral arbMin, maxCoins)
--        return (arbMin, fromIntegral arbMax)

genRunChanPair :: Word -> (BtcAmount,BtcAmount) -> BtcAmount -> IO ChannelPairResult
genRunChanPair numPayments (rangeMin,rangeMax) initAmount = do
    amountList <- fmap (map conv) <$> generate $
        vectorOf (conv numPayments) (choose (conv rangeMin, conv rangeMax) :: Gen Word64)
    (arbPair,_) <- generate $ mkChanPairInitAmount initAmount
    runChanPair arbPair amountList
  where
    conv :: (Integral a, Num b) => a -> b
    conv = fromIntegral

-- | Funding transaction with a funding output at an arbitrary output index
arbitraryFundingTx
    :: ChanParams
    -> BtcAmount        -- ^ Funding amount
    -> Gen (Word32, Tx) -- ^ Output index of funding output plus transaction
arbitraryFundingTx cp val = do
    ArbitraryTx tx <- arbitrary
    let mkP2shOut = Bin.encode . HS.encodeOutput . HS.PayScriptHash
        out = HT.TxOut (fromIntegral val) (mkP2shOut $ getP2SHFundingAddress cp)
    (idx,newOuts) <- arbitraryInsert (HT.txOut tx) out
    let newTx = HT.createTx (HT.txVersion tx) (HT.txIn tx) newOuts (HT.txLockTime tx)
    return (fromIntegral idx :: Word32, newTx)

-- | Insert an element into a list at an arbitrary position
arbitraryInsert :: forall a. [a] -> a -> Gen (Int, [a])
arbitraryInsert lst a = do
    idx <- choose (0, length lst)
    let (preLst,postLst) = splitAt idx lst
        newLst = preLst ++ [a] ++ postLst
    return (idx, newLst)

-- TODO: We don't bother testing expiration time for now
nowishTimestamp :: UTCTime
nowishTimestamp = UTCTime (ModifiedJulianDay 50000) 0


createAcceptClosingPayment
    :: ChangeOutFee fee
    => HC.Address
    -> fee
    -> ChannelPairResult
    -> Either PayChanError ClosedServerChanX
createAcceptClosingPayment addr fee ChannelPairResult{..} =
    resultFromThePast $ acceptClosingPayment (toPaymentData closingPayment) resRecvChan
  where
    (_,closingPayment,_) = createClosingPayment resSendChan addr fee