{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Main where
import Data.Bitcoin.PaymentChannel
import Data.Bitcoin.PaymentChannel.Types
import Data.Bitcoin.PaymentChannel.Util
import qualified Data.Bitcoin.PaymentChannel.Internal.State as S
import qualified Network.Haskoin.Transaction as HT
import qualified Network.Haskoin.Crypto as HC
import qualified Network.Haskoin.Script as HS
import Network.Haskoin.Test
import qualified Data.Aeson as JSON
import qualified Data.Serialize as Bin
import Data.Typeable
import Data.Time.Clock (UTCTime(..))
import Data.Time.Calendar (Day(..))
import Test.QuickCheck
import Test.Framework (Test, testGroup, defaultMain)
import Test.Framework.Providers.QuickCheck2 (testProperty)
-- |We don't bother testing timestamps for now
nowishTimestamp :: UTCTime
nowishTimestamp = UTCTime (ModifiedJulianDay 57683) 0 -- 2016-10-22
mIN_CHANNEL_SIZE :: BitcoinAmount
mIN_CHANNEL_SIZE = cDustLimit defaultConfig * 2
testAddrTestnet :: HC.Address
testAddrTestnet = "2N414xMNQaiaHCT5D7JamPz7hJEc9RG7469"
testAddrLivenet :: HC.Address
testAddrLivenet = "14wjVnwHwMAXDr6h5Fw38shCWUB6RSEa63"
main :: IO ()
main = defaultMain tests
tests :: [Test]
tests =
[ testGroup "Payment"
[ testProperty "Sender value in settlement tx" $
testPaymentSession checkSenderValue
, testProperty "Receiver value in settlement tx" $
testPaymentSession checkReceiverValue
, testProperty "Sender/receiver state match" $
testPaymentSession checkSendRecvStateMatch
, testProperty "Sent amount == received amount" $
testPaymentSession checkRecvSendAmount
]
, testGroup "Serialization"
[ testProperty "FullPayment JSON" (jsonSerDeser :: FullPayment -> Bool)
, testProperty "FullPayment Binary" testPaymentBin
-- Fails: https://github.com/haskoin/haskoin/issues/287
-- , testProperty "ChanScript ser/deser" testScriptBin
]
]
testPaymentJSON :: FullPayment -> Bool
testPaymentJSON = jsonSerDeser
testPaymentBin :: FullPayment -> Bool
testPaymentBin = binSerDeser
testScriptBin :: ChanScript -> Bool -- Fails: https://github.com/haskoin/haskoin/issues/287
testScriptBin = binSerDeser
checkSenderValue :: (ArbChannelPair, [BitcoinAmount]) -> Bool
checkSenderValue (ArbChannelPair _ recvChan amountSent _ recvSignFunc, _) = do
let settleTx = getSettlementBitcoinTx recvChan recvSignFunc testAddrLivenet 0
let clientChangeAmount = HT.outValue . head . HT.txOut $ settleTx
-- Check that the client change amount in the settlement transaction equals the
-- channel funding amount minus the sum of all payment amounts.
let fundAmountMinusPaySum = S.pcsChannelTotalValue (getChannelState recvChan) -
fromIntegral (sum amountSent)
fromIntegral clientChangeAmount == fundAmountMinusPaySum
checkReceiverValue :: (ArbChannelPair, [BitcoinAmount]) -> Bool
checkReceiverValue (ArbChannelPair _ recvChan amountSent _ recvSignFunc, _) = do
let settleTx = getSettlementBitcoinTx recvChan recvSignFunc testAddrLivenet 0
let receiverAmount = HT.outValue (HT.txOut settleTx !! 1)
-- Check receiver amount in settlement transaction with zero fee equals sum
-- of all payments.
(fromIntegral receiverAmount :: BitcoinAmount) == fromIntegral (sum amountSent)
checkSendRecvStateMatch :: (ArbChannelPair, [BitcoinAmount]) -> Bool
checkSendRecvStateMatch (ArbChannelPair sendChan recvChan _ _ _, _) =
getChannelState sendChan == getChannelState recvChan
checkRecvSendAmount :: (ArbChannelPair, [BitcoinAmount]) -> Bool
checkRecvSendAmount (ArbChannelPair _ _ amountSent amountRecvd _, _) =
amountSent == amountRecvd
testPaymentSession ::
((ArbChannelPair, [BitcoinAmount]) -> Bool)
-> ArbChannelPair
-> [BitcoinAmount]
-> Bool
testPaymentSession testFunc arbChanPair paymentAmountList =
testFunc (runChanPair arbChanPair paymentAmountList)
runChanPair :: ArbChannelPair -> [BitcoinAmount] -> (ArbChannelPair, [BitcoinAmount])
runChanPair chanPair paymentAmountList =
(foldl doPayment chanPair paymentAmountList, paymentAmountList)
jsonSerDeser :: (Show a, Eq a, JSON.FromJSON a, JSON.ToJSON a) => a -> Bool
jsonSerDeser fp =
maybe False checkEquals decodedObj
where json = JSON.encode fp
decodedObj = JSON.decode json
checkEquals serDeserVal =
if serDeserVal /= fp then
error ("Ser/deser mismatch.\nOriginal: " ++ show fp ++ "\nCopy: " ++ show decodedObj)
else
True
binSerDeser :: (Typeable a, Show a, Eq a, Bin.Serialize a) => a -> Bool
binSerDeser fp =
checkEquals decodeRes
where bs = Bin.encode fp
decodeRes = deserEither bs
checkEquals serDeserRes = case serDeserRes of
Left e -> error $ "Serialize/deserialize error: " ++ show e
Right res -> if res /= fp then
error ("Ser/deser mismatch.\nOriginal: " ++ show fp ++ "\nCopy: " ++ show res)
else
True
data ArbChannelPair = ArbChannelPair
SenderPaymentChannel ReceiverPaymentChannel [BitcoinAmount] [BitcoinAmount] (HC.Hash256 -> HC.Signature)
instance Show ArbChannelPair where
show (ArbChannelPair spc rpc _ _ _) =
"SendState: " ++ show spc ++ "\n" ++
"RecvState: " ++ show rpc
doPayment :: ArbChannelPair -> BitcoinAmount -> ArbChannelPair
doPayment (ArbChannelPair spc rpc sendList recvList f) amount =
let
(amountSent, pmn, newSpc) = sendPayment spc amount
eitherRpc = recvPayment nowishTimestamp rpc pmn
in
case eitherRpc of
Left e -> error (show e)
Right (recvAmount, newRpc) ->
ArbChannelPair newSpc newRpc
(amountSent : sendList)
(recvAmount : recvList)
f
newtype ChanScript = ChanScript HS.Script deriving (Eq,Show,Bin.Serialize)
instance Arbitrary ArbChannelPair where
arbitrary = fmap fst mkChanPair
instance Arbitrary FullPayment where
arbitrary = fmap snd mkChanPair
instance Arbitrary ChannelParameters where
arbitrary = fmap fst mkChanParams
instance Arbitrary ChanScript where
arbitrary = ChanScript . getRedeemScript <$> arbitrary
mkChanParams :: Gen (ChannelParameters, (HC.PrvKey, HC.PrvKey))
mkChanParams = do
-- sender key pair
ArbitraryPubKey sendPriv sendPK <- arbitrary
-- receiver key pair
ArbitraryPubKey recvPriv recvPK <- arbitrary
-- TODO: We use an expiration date far off into the future for now
let lockTime = parseBitcoinLocktime 2524651200
return (CChannelParameters
(MkSendPubKey sendPK) (MkRecvPubKey recvPK) lockTime,
(sendPriv, recvPriv))
mkChanPair :: Gen (ArbChannelPair, FullPayment)
mkChanPair = do
(cp, (sendPriv, recvPriv)) <- mkChanParams
fti <- arbitrary
-- value of first payment
initPayAmount <- arbitrary
-- create states
let (initPayActualAmount,paymnt,sendChan) = channelWithInitialPaymentOf defaultConfig
cp fti (flip HC.signMsg sendPriv) (getFundingAddress cp) initPayAmount
let eitherRecvChan = channelFromInitialPayment nowishTimestamp defaultConfig cp fti paymnt
case eitherRecvChan of
Left e -> error (show e)
Right (initRecvAmount,recvChan) -> return
(ArbChannelPair
sendChan recvChan [initPayActualAmount] [initRecvAmount]
(flip HC.signMsg recvPriv),
paymnt)
instance Arbitrary FundingTxInfo where
arbitrary = do
ArbitraryTxHash h <- arbitrary
i <- arbitrary
amt <- fmap fromIntegral
(choose (fromIntegral mIN_CHANNEL_SIZE, round $ 21e6 * 1e8 :: Integer))
:: Gen BitcoinAmount
return $ CFundingTxInfo h i amt
instance Arbitrary BitcoinAmount where
arbitrary = fromIntegral <$> choose (0, round $ 21e6 * 1e8 :: Integer)