diff --git a/bitcoin-payment-channel.cabal b/bitcoin-payment-channel.cabal --- a/bitcoin-payment-channel.cabal +++ b/bitcoin-payment-channel.cabal @@ -1,5 +1,5 @@ name: bitcoin-payment-channel -version: 0.5.0.1 +version: 0.6.0.0 synopsis: Library for working with Bitcoin payment channels description: A Bitcoin payment channel allows secure and instant transfer of bitcoins from one @@ -34,22 +34,25 @@ exposed-modules: Data.Bitcoin.PaymentChannel Data.Bitcoin.PaymentChannel.Types Data.Bitcoin.PaymentChannel.Util - -- Exposed for testing purposes - Data.Bitcoin.PaymentChannel.Internal.State + Data.Bitcoin.PaymentChannel.Test - other-modules: Data.Bitcoin.PaymentChannel.Internal.Error + other-modules: Data.Bitcoin.PaymentChannel.Internal.State + Data.Bitcoin.PaymentChannel.Internal.Error Data.Bitcoin.PaymentChannel.Internal.Payment Data.Bitcoin.PaymentChannel.Internal.Refund Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Amount Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Script Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Util Data.Bitcoin.PaymentChannel.Internal.Bitcoin.LockTime + Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Fee + Data.Bitcoin.PaymentChannel.Internal.Crypto.PubKey Data.Bitcoin.PaymentChannel.Internal.Settlement Data.Bitcoin.PaymentChannel.Internal.Types Data.Bitcoin.PaymentChannel.Internal.Serialization Data.Bitcoin.PaymentChannel.Internal.Util - ghc-options: -W + + ghc-options: -Wall default-language: Haskell2010 build-depends: base >= 4.7 && < 5, @@ -64,7 +67,8 @@ aeson >= 0.11.0 && < 0.12.0, scientific >= 0.3.0 && < 0.4.0, string-conversions >= 0.4 && < 0.5, - tagged >= 0.8 && < 1.0 + tagged >= 0.8 && < 1.0, + QuickCheck >= 2.8 && < 2.9 hs-source-dirs: src @@ -74,10 +78,12 @@ main-is: Main.hs default-language: Haskell2010 hs-source-dirs: test - ghc-options: -W + ghc-options: -Wall - build-depends: base >= 4.7 && < 5, - haskoin-core >= 0.4.0 && < 1.0.0, + build-depends: base >= 4.7 && < 5, + haskoin-core >= 0.4.0 && < 1.0.0, + QuickCheck >= 2.8 && < 2.9, + bytestring, base16-bytestring, base64-bytestring, hexstring, text, @@ -85,5 +91,5 @@ time, cereal, aeson, - QuickCheck, test-framework, test-framework-quickcheck2, + test-framework, test-framework-quickcheck2, bitcoin-payment-channel diff --git a/src/Data/Bitcoin/PaymentChannel.hs b/src/Data/Bitcoin/PaymentChannel.hs --- a/src/Data/Bitcoin/PaymentChannel.hs +++ b/src/Data/Bitcoin/PaymentChannel.hs @@ -8,12 +8,11 @@ Portability : POSIX In order to set up a payment channel between a sender and a receiver, the two parties must - first agree on four parameters for the channel: + first agree on three [1] parameters for the channel: (1) sender public key (2) receiver public key (3) channel expiration date - (4) sender change output "dust limit" (see note [1]) These parameters are contained in 'ChannelParameters', from which the Bitcoin address used to fund @@ -68,11 +67,21 @@ signing function passed to 'getSettlementBitcoinTx', where @receiverPrivKey@ is the private key from which 'cpReceiverPubKey' is derived. -[1] The minimum amount that the server is willing to accept as the client change value in the - payment transaction. Set this to 700 and you'll be fine. It's only relevant if the channel is +[1] In addition to this, two configuration options must also be agreed upon: a "dust limit", + and a "settlement period" (measured in hours), which is subtracted from the channel expiration + date in order to arrive at the effective (earlier) expiration date. This is necessary to give the + server/receiver time to publish the settlement transaction before the refund transaction becomes + valid. The dust limit is the minimum amount that the server is willing to accept + as the client change value in the + payment transaction. It's only relevant if the channel is emptied of value completely, but it is necessary because the server doesn't want to accept payments based on transactions it cannot publish via the Bitcoin P2P network, because they - contain an output of minuscule value. + contain an output of minuscule value. Sensible values are contained in 'defaultConfig', but + client/sender and server/receiver need to agree on these parameter as well, although they are + only relevant 1) (in the case of the dust limit) if the channel is compleltely exchausted and + 2) (in case of the "settlemend period") if the client tries to make payments close to expiration + (and, in case the client does, it will just receive an error in response, saying the channel + is now closed). __/IMPORTANT:/__ /Channel setup is risk free because the sender can derive a refund Bitcoin transaction/ /using 'getRefundBitcoinTx', which returns the bitcoins used to fund the channel back to the sender./ @@ -88,22 +97,29 @@ module Data.Bitcoin.PaymentChannel ( - channelWithInitialPaymentOf, - sendPayment, + -- *Initialization + -- **Funding + getFundingAddress, + + -- **State creation + channelWithInitialPaymentOf, channelFromInitialPayment, + + -- *Payment + sendPayment, recvPayment, - recvPaymentForClose, + -- *Settlement + recvPaymentForClose, getSettlementBitcoinTx, - getRefundBitcoinTx, - - getFundingAddress + getRefundBitcoinTx ) where import Data.Bitcoin.PaymentChannel.Internal.Types (PaymentTxConfig(..), Payment(..), FullPayment(..), Config, + ReceiverPaymentChannelI(..), PaymentChannelState, pcsConfig, pcsClientChangeVal, pcsParameters) import Data.Bitcoin.PaymentChannel.Internal.State (newPaymentChannelState, updatePaymentChannelState, isPastLockTimeDate) @@ -112,8 +128,7 @@ (createPayment, paymentFromState, verifyPaymentSigFromState) import Data.Bitcoin.PaymentChannel.Internal.Settlement (signedSettlementTxFromState) -import Data.Bitcoin.PaymentChannel.Internal.Refund - (refundTxAddSignature, getRefundTxHashForSigning) +import Data.Bitcoin.PaymentChannel.Internal.Refund (mkRefundTx) import Data.Bitcoin.PaymentChannel.Util (getFundingAddress) import Data.Bitcoin.PaymentChannel.Types @@ -130,9 +145,9 @@ -- Returns a new 'SenderPaymentChannel' state object and the first channel payment. channelWithInitialPaymentOf :: Config -- ^ Various configuration options. 'defaultConfig' contains sensible defaults. - -> ChannelParameters -- ^ Specifies channel sender and receiver, channel expiration date and "dust limit" + -> ChannelParameters -- ^ Specifies channel sender and receiver, channel expiration date -> FundingTxInfo -- ^ Holds information about the Bitcoin transaction used to fund the channel - -> (HC.Hash256 -> HC.Signature) -- ^ Used to sign payments from sender. When given a 'HC.Hash256', produces a signature that verifies against sender PubKey. + -> (HC.Hash256 -> HC.Signature) -- ^ Used to sign payments from sender. When given a 'HC.Hash256', produces a signature that verifies against sender pubkey. -> HC.Address -- ^ Value sender/client change address -> BitcoinAmount -- ^ Value of initial payment. Can be zero. -> (BitcoinAmount, FullPayment, SenderPaymentChannel) -- ^Initial payment amount (may be capped), initial payment, and new sender state object @@ -167,12 +182,13 @@ -- Will not be accepted by the Bitcoin network until the expiration time specified in -- 'ChannelParameters'. Receiver beware of Bitcoin network time drift and the -- unpreditable nature of finding new blocks. -getRefundBitcoinTx :: - SenderPaymentChannel -- ^Sender state object - -> BitcoinAmount -- ^Refund transaction fee - -> HT.Tx -- ^Refund Bitcoin transaction +getRefundBitcoinTx + :: HasFee fee + => SenderPaymentChannel -- ^Sender state object + -> fee -- ^Refund transaction fee + -> HT.Tx -- ^Refund Bitcoin transaction getRefundBitcoinTx (CSenderPaymentChannel cs signFunc) txFee = - refundTxAddSignature cs txFee $ signFunc $ getRefundTxHashForSigning cs txFee + mkRefundTx cs txFee signFunc -- |Create new 'ReceiverPaymentChannel'. @@ -192,17 +208,17 @@ in flip (recvPayment now) fp $ CReceiverPaymentChannel -- Create a new state with the unverified signature; then verify the same signature in 'recvPayment' - (newPaymentChannelState cfg cp fundInf pConf sig) + (newPaymentChannelState cfg cp fundInf pConf sig) () -- |Register, on the receiving side, a payment made by 'sendPayment' on the sending side. -- Returns error if either the signature or payment amount is invalid, and otherwise -- the amount received with this 'Payment' and a new state object. recvPayment :: - UTCTime -- ^Current time. Needed for payment verification. - -> ReceiverPaymentChannel -- ^Receiver state object - -> FullPayment -- ^Payment to verify and register - -> Either PayChanError (BitcoinAmount, ReceiverPaymentChannel) -- ^Value received plus new receiver state object -recvPayment currentTime rpc@(CReceiverPaymentChannel oldState) fp@(CFullPayment paymnt _ _ _) = + UTCTime -- ^Current time. Needed for payment verification. + -> ReceiverPaymentChannelI a -- ^Receiver state object + -> FullPayment -- ^Payment to verify and register + -> Either PayChanError (BitcoinAmount, ReceiverPaymentChannelI a) -- ^Value received plus new receiver state object +recvPayment currentTime rpc@(CReceiverPaymentChannel oldState _) fp@(CFullPayment paymnt _ _ _) = updatePaymentChannelState oldState fp >>= checkExpiration >>= verifyPaymentSignature paymnt >>= @@ -231,16 +247,19 @@ -- with a new client change address. Used to produce the settlement -- transaction that returns unsent funds to the client. recvPaymentForClose :: - ReceiverPaymentChannel -- ^Receiver state object - -> FullPayment -- ^Payment to verify and register - -> Either PayChanError ReceiverPaymentChannel -- ^ Receiver state object -recvPaymentForClose (CReceiverPaymentChannel state) fp = + ReceiverPaymentChannelI a -- ^Receiver state object + -> FullPayment -- ^Payment to verify and register + -> Either PayChanError (ReceiverPaymentChannelI a) -- ^ Receiver state object +recvPaymentForClose (CReceiverPaymentChannel state pki) fp = recvPayment futureTimeStamp newAddressState fp >>= \(amtRecv, newState) -> case amtRecv of 0 -> Right newState _ -> Left ClosingPaymentBadValue - where newAddressState = CReceiverPaymentChannel $ - S.setClientChangeAddress state (fpChangeAddr fp) + where newAddressState = CReceiverPaymentChannel + { rpcState = S.setClientChangeAddress state (fpChangeAddr fp) + , rpcPubKeyInfo = pki + } + -- When receiving a payment of zero value, which only modifies the -- client change address, we don't care about verifying that the channel -- hasn't expired yet (which it may well have, since the client wants its @@ -252,13 +271,14 @@ -- is included in a Bitcoin block before the refund transaction becomes valid (see 'getRefundBitcoinTx'). -- The sender can only close the channel before expiration by requesting this transaction -- from the receiver and publishing it to the Bitcoin network. -getSettlementBitcoinTx :: - ReceiverPaymentChannel -- ^ Receiver state object - -> (HC.Hash256 -> HC.Signature) -- ^ Function which produces a signature which verifies against 'cpReceiverPubKey' +getSettlementBitcoinTx + :: HasFee fee + => ReceiverPaymentChannelI a -- ^ Receiver state object -> HC.Address -- ^ Receiver destination address. Funds sent over the channel will be sent to this address, the rest back to the client change address (an argument to 'channelWithInitialPaymentOf'). - -> BitcoinAmount -- ^ Bitcoin transaction fee + -> (HC.Hash256 -> HC.Signature) -- ^ Function which produces a signature which verifies against 'cpReceiverPubKey' + -> fee -- ^ Bitcoin transaction fee -> HT.Tx -- ^ Settling Bitcoin transaction -getSettlementBitcoinTx (CReceiverPaymentChannel cs) = +getSettlementBitcoinTx (CReceiverPaymentChannel cs _) = signedSettlementTxFromState cs diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Amount.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Amount.hs --- a/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Amount.hs +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Amount.hs @@ -4,31 +4,31 @@ import qualified Data.Serialize.Put as SerPut import qualified Data.Serialize.Get as SerGet import Data.Word +import Data.Ratio -- |Represents a bitcoin amount as number of satoshis. --- 1 satoshi = 1e-8 bitcoin. --- Only natural numbers (>= 0) can be represented ('fromInteger' caps to a 'Word64'). --- It is thus not possible to construct a negative BitcoinAmount which, when added to --- another BitcoinAmount, subtracts from its value. So we avoid the problem of being --- able to invert subtraction/addition by supplying a negative value as one of the --- arguments. +-- 1 satoshi = 1e-8 bitcoin. 1e8 satohis = 1 bitcoin. +-- Only amounts >= 0 can be represented, and 'fromInteger' caps to a 'Word64'. +-- It is thus not possible to eg. construct a negative BitcoinAmount which, when added to +-- another BitcoinAmount, subtracts from its value. Adding two large amounts together will +-- never overflow, nor will subtraction underflow. newtype BitcoinAmount = BitcoinAmount Integer deriving (Eq, Ord) instance Show BitcoinAmount where show amount = show (toInteger amount) ++ " satoshi" instance Num BitcoinAmount where - (BitcoinAmount a1) * (BitcoinAmount a2) = BitcoinAmount (fromIntegral . capToWord64 $ a1*a2) - (BitcoinAmount a1) + (BitcoinAmount a2) = BitcoinAmount (fromIntegral . capToWord64 $ a1+a2) - (BitcoinAmount a1) - (BitcoinAmount a2) = BitcoinAmount (fromIntegral . capToWord64 $ a1-a2) + (BitcoinAmount a1) * (BitcoinAmount a2) = BitcoinAmount (fromIntegral . capTo21Mill $ a1*a2) + (BitcoinAmount a1) + (BitcoinAmount a2) = BitcoinAmount (fromIntegral . capTo21Mill $ a1+a2) + (BitcoinAmount a1) - (BitcoinAmount a2) = BitcoinAmount (fromIntegral . capTo21Mill $ a1-a2) abs = id -- Always positive signum (BitcoinAmount 0) = BitcoinAmount 0 signum (BitcoinAmount _) = BitcoinAmount 1 - fromInteger = BitcoinAmount . fromIntegral . capToWord64 + fromInteger = BitcoinAmount . fromIntegral . capTo21Mill instance Enum BitcoinAmount where - toEnum = BitcoinAmount . fromIntegral . capToWord64 . fromIntegral + toEnum = BitcoinAmount . fromIntegral . capTo21Mill . fromIntegral fromEnum (BitcoinAmount amount) = fromIntegral amount instance Real BitcoinAmount where @@ -36,15 +36,22 @@ instance Integral BitcoinAmount where toInteger (BitcoinAmount int) = int - quotRem (BitcoinAmount _) (BitcoinAmount _) = - error "Division of two BitcoinAmounts is undefined" + quotRem (BitcoinAmount a1) (BitcoinAmount a2) = + ( BitcoinAmount (fromIntegral . capTo21Mill $ res1) + , BitcoinAmount (fromIntegral . capTo21Mill $ res2) + ) + where (res1,res2) = quotRem a1 a2 --- | Convert to 'Word64', with zero as floor, (maxBound :: Word64) as ceiling -capToWord64 :: Integer -> Word64 -capToWord64 i = fromIntegral $ +instance Bounded BitcoinAmount where + minBound = BitcoinAmount 0 + maxBound = BitcoinAmount $ round $ (21e6 :: Ratio Integer) * (1e8 :: Ratio Integer) + +-- | Convert to 21 million, zero as floor +capTo21Mill :: Integer -> Word64 +capTo21Mill i = fromIntegral $ max 0 cappedValue where - cappedValue = min i $ fromIntegral (maxBound :: Word64) + cappedValue = min i $ fromIntegral (maxBound :: BitcoinAmount) instance Ser.Serialize BitcoinAmount where put = SerPut.putWord64le . fromIntegral . toInteger diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Fee.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Fee.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Fee.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Fee where + +import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Amount +import qualified Data.Serialize as Bin + + +-- |Objects from which a Bitcoin fee can be calculated, +-- given a transaction (yeah you need to create a tx twice). +class HasFee a where + absoluteFee :: TxByteSize -> a -> BitcoinAmount + +-- |For compatibility +instance HasFee BitcoinAmount where + absoluteFee _ = id -- Same as constant fee + +data Constant = Constant BitcoinAmount +instance HasFee Constant where + absoluteFee _ (Constant amt) = amt + +type TxByteSize = Word +-- |Specify a fee as satoshis per byte +newtype SatoshisPerByte = SatoshisPerByte BitcoinAmount -- ^Fee in satoshis per byte + deriving (Eq, Show, Bin.Serialize, Ord, Num, Enum, Real, Integral) +instance HasFee SatoshisPerByte where + absoluteFee txByteSize (SatoshisPerByte satoshisPerByte) = + fromIntegral txByteSize * satoshisPerByte + diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Script.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Script.hs --- a/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Script.hs +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Script.hs @@ -16,7 +16,10 @@ -- |Generates OP_CHECKLOCKTIMEVERIFY redeemScript, which can be redeemed in two ways: -- 1) by providing a signature from both server and client -- 2) after the date specified by lockTime: by providing only a client signature -paymentChannelRedeemScript :: SendPubKey -> RecvPubKey -> BitcoinLockTime -> Script +paymentChannelRedeemScript :: SendPubKey + -> RecvPubKey + -> BitcoinLockTime + -> Script paymentChannelRedeemScript clientPK serverPK lockTime = let -- Note: HI.encodeInt encodes values up to and including 2^31-1 as 4 bytes @@ -33,7 +36,7 @@ [OP_IF, opPushData $ serialize serverPubKey, OP_CHECKSIGVERIFY, OP_ELSE, - encodeScriptInt $ lockTime, op_CHECKLOCKTIMEVERIFY, OP_DROP, + encodeScriptInt lockTime, op_CHECKLOCKTIMEVERIFY, OP_DROP, OP_ENDIF, opPushData $ serialize clientPubKey, OP_CHECKSIG] @@ -51,7 +54,8 @@ refundTxScriptSig :: HC.Signature -> Script refundTxScriptSig clientSig = Script [opPushData (B.append (serialize clientSig) hashTypeByte), - OP_0] -- Signal that we want to provide only one PubKey + OP_0] -- Signal that we want to provide only one pubkey/sig pair (sender's), + -- after it is checked that the lockTime has expired in the script where hashTypeByte = serialize (SigAll False) -----Util----- diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Util.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Util.hs --- a/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Util.hs +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Util.hs @@ -52,7 +52,7 @@ HT.createTx (HT.txVersion tx) (HT.txIn tx) ( oldOuts ++ [txOut] ) (HT.txLockTime tx) where oldOuts = HT.txOut tx -bitcoinPayPK :: HC.PubKey -> HS.Script +bitcoinPayPK :: HC.PubKeyC -> HS.Script bitcoinPayPK pk = HS.encodeOutput $ HS.PayPKHash $ HC.pubKeyAddr pk bitcoinPayPKBS = serialize . bitcoinPayPK where serialize = Ser.encode diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Crypto/PubKey.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Crypto/PubKey.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Crypto/PubKey.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Data.Bitcoin.PaymentChannel.Internal.Crypto.PubKey +( IsPubKey(..) +, SendPubKey(..) +, RecvPubKey(..) +) where + +import qualified Network.Haskoin.Crypto as HC +import qualified Data.Serialize as Bin + +-- |Types which contain a pubkey +class Bin.Serialize a => IsPubKey a where + getPubKey :: a -> HC.PubKeyC + +-- |Wrapper for value sender's public key +newtype SendPubKey = MkSendPubKey { + getSenderPK :: HC.PubKeyC +} deriving (Eq, Show, Bin.Serialize) +instance IsPubKey SendPubKey where + getPubKey = getSenderPK + +-- |Wrapper for value receiver's public key +newtype RecvPubKey = MkRecvPubKey { + getReceiverPK :: HC.PubKeyC +} deriving (Eq, Show, Bin.Serialize) +instance IsPubKey RecvPubKey where + getPubKey = getReceiverPK + +instance IsPubKey HC.XPubKey where + getPubKey = HC.xPubKey diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Error.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Error.hs --- a/src/Data/Bitcoin/PaymentChannel/Internal/Error.hs +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Error.hs @@ -7,28 +7,24 @@ import GHC.Generics data PayChanError = - SigVerifyFailed | - BadPaymentValue BitcoinAmount | - OutPointMismatch OutPoint | - ChangeAddrMismatch Address | - RedeemScriptMismatch Script | - DustOutput BitcoinAmount | - PartialPaymentBadValue BitcoinAmount | - ClosingPaymentBadValue | - ChannelExpired + SigVerifyFailed -- ^Signature verification failed + | BadPaymentValue BitcoinAmount -- ^Payment assigns less value to server than previous payment. Client change value is greater by the specified 'BitcoinAmount'. + | OutPointMismatch OutPoint -- ^'Network.Haskoin.Transaction.OutPoint' in payment does not match the one in server's state + | ChangeAddrMismatch Address -- ^Client change 'Network.Haskoin.Crypto.Address' in payment does not match the one in server's state + | RedeemScriptMismatch Script -- ^redeemScript in payment does not match the one in server's state + | DustOutput BitcoinAmount -- ^Client change value is less than dust limit (payment transaction would contain a dust output) + | ClosingPaymentBadValue -- ^The closing payment only changes the payment transaction change address. Sending value is not allowed. + | ChannelExpired -- ^Channel has expired or is too close to expiration date deriving Generic instance Show PayChanError where - show SigVerifyFailed = "signature verification failed" + show SigVerifyFailed = "Signature verification failed" show (BadPaymentValue valDiff) = "out-of-order payment (assigns " ++ show valDiff ++ " less value to receiver)" show (OutPointMismatch op) = "unexpected outpoint. expected: " ++ show op show (ChangeAddrMismatch addr) = "unexpected change address. expected: " ++ show addr show (RedeemScriptMismatch scr) = "unexpected redeem script. expected: " ++ cs (serHex scr) - show (PartialPaymentBadValue expVal) = "partial payment change value mismatch." ++ - " payment 1/2 with change value " ++ show expVal ++ - " was accepted, expecting second payment change value to match that." show (DustOutput limit) = "server dust limit of " ++ show limit ++ " not respected by client change output" show ClosingPaymentBadValue = "payment not of zero value." ++ diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Refund.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Refund.hs --- a/src/Data/Bitcoin/PaymentChannel/Internal/Refund.hs +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Refund.hs @@ -5,11 +5,13 @@ import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Script import Data.Bitcoin.PaymentChannel.Internal.Payment import Data.Bitcoin.PaymentChannel.Internal.Util +import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Fee import qualified Network.Haskoin.Transaction as HT import qualified Network.Haskoin.Crypto as HC import qualified Network.Haskoin.Script as HS + getUnsignedRefundTx :: PaymentChannelState -> BitcoinAmount -> HT.Tx getUnsignedRefundTx st txFee = let @@ -30,22 +32,31 @@ (toWord32 $ pcsLockTime st) -getRefundTxHashForSigning :: - PaymentChannelState +getRefundTxHashForSigning + :: PaymentChannelState -> BitcoinAmount -- ^Bitcoin transaction fee -> HC.Hash256 -getRefundTxHashForSigning pcs@(CPaymentChannelState _ cp _ _ _ _ _) newValueLeft = +getRefundTxHashForSigning pcs@(CPaymentChannelState _ cp _ _ _ _ _) txFee = HS.txSigHash tx (getRedeemScript cp) 0 (HS.SigAll False) - where tx = getUnsignedRefundTx pcs newValueLeft + where tx = getUnsignedRefundTx pcs txFee -refundTxAddSignature :: +refundTxCreate :: PaymentChannelState - -> BitcoinAmount -- ^Bitcoin tx fee - -> HC.Signature -- ^Signature over 'getUnsignedRefundTx' which verifies against clientPubKey - -> FinalTx -refundTxAddSignature pcs@(CPaymentChannelState _ cp _ _ _ _ _) txFee clientRawSig = + -> BitcoinAmount -- ^Bitcoin tx fee + -> (HC.Hash256 -> HC.Signature) -- ^Produces a signature that verifies against clientPubKey + -> HT.Tx +refundTxCreate pcs@(CPaymentChannelState _ cp _ _ _ _ _) txFee signFunc = let - inputScript = getP2SHInputScript cp $ refundTxScriptSig clientRawSig + inputScript = getP2SHInputScript cp $ refundTxScriptSig sig + sig = signFunc $ getRefundTxHashForSigning pcs txFee in replaceScriptInput 0 (serialize inputScript) $ getUnsignedRefundTx pcs txFee + + +mkRefundTx :: HasFee fee => PaymentChannelState -> fee -> (HC.Hash256 -> HC.Signature) -> HT.Tx +mkRefundTx pcs txFee signFunc = + refundTxCreate pcs (absoluteFee (calcTxSize zeroFeeTx) txFee) signFunc + where + zeroFeeTx = refundTxCreate pcs (0 :: BitcoinAmount) signFunc + diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Serialization.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Serialization.hs --- a/src/Data/Bitcoin/PaymentChannel/Internal/Serialization.hs +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Serialization.hs @@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, TypeSynonymInstances, FlexibleInstances #-} module Data.Bitcoin.PaymentChannel.Internal.Serialization where @@ -98,9 +97,6 @@ (BinGet.getWord16be >>= BinGet.getByteString . fromIntegral) -deriving instance Bin.Serialize SendPubKey -deriving instance Bin.Serialize RecvPubKey - instance Bin.Serialize PaymentChannelState where put (CPaymentChannelState cfg par fti payConf payCount valLeft sig) = Bin.put cfg >> Bin.put par >> Bin.put fti >> Bin.put payConf >> Bin.put payCount >> @@ -154,12 +150,6 @@ "" --- Needed to convert from Scientific -instance Bounded BitcoinAmount where - minBound = BitcoinAmount 0 - maxBound = BitcoinAmount $ round $ 21e6 * 1e8 - - parseJSONInt :: Scientific -> Parser Integer parseJSONInt s = case toBoundedInteger s of @@ -171,3 +161,14 @@ case toBoundedInteger s of Just w -> return w Nothing -> fail $ "failed to decode JSON number to Word64. data: " ++ show s + + +instance Bin.Serialize ReceiverPaymentChannel where + put (CReceiverPaymentChannel rpc _ ) = + Bin.put rpc >> Bin.putWord8 0x01 + get = CReceiverPaymentChannel <$> Bin.get <*> return () + +instance Bin.Serialize ReceiverPaymentChannelX where + put (CReceiverPaymentChannel rpc pki ) = + Bin.put rpc >> Bin.putWord8 0x02 >> Bin.put pki + get = CReceiverPaymentChannel <$> Bin.get <*> Bin.get diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Settlement.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Settlement.hs --- a/src/Data/Bitcoin/PaymentChannel/Internal/Settlement.hs +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Settlement.hs @@ -1,10 +1,16 @@ -module Data.Bitcoin.PaymentChannel.Internal.Settlement where +module Data.Bitcoin.PaymentChannel.Internal.Settlement +( + createSignedSettlementTx +, signedSettlementTxFromState +) +where import Data.Bitcoin.PaymentChannel.Internal.Types import Data.Bitcoin.PaymentChannel.Internal.Payment import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Script import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Util import Data.Bitcoin.PaymentChannel.Internal.Util +import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Fee import qualified Network.Haskoin.Transaction as HT import qualified Network.Haskoin.Crypto as HC @@ -13,10 +19,6 @@ -- |Sign everything, and do not allow additional inputs to be added afterwards. serverSigHash = HS.SigAll False -csFromState :: PaymentChannelState -> ClientSignedPayment -csFromState cs@(CPaymentChannelState _ _ _ _ _ _ clientSig) = - ClientSignedPayment (fromState cs) clientSig - toUnsignedSettlementTx :: ClientSignedPayment -> HC.Address -> BitcoinAmount -> HT.Tx toUnsignedSettlementTx (ClientSignedPayment @@ -33,46 +35,56 @@ in appendOutput adjustedTx recvOut -getSettlementTxHashForSigning :: - ClientSignedPayment +getSettlementTxHashForSigning + :: ClientSignedPayment -> ChannelParameters -> HC.Address -- ^Receiver destination address - -> BitcoinAmount -- ^Bitcoin transaction fee + -> BitcoinAmount -- ^Bitcoin transaction fee -> HC.Hash256 getSettlementTxHashForSigning csPayment cp recvAddr txFee = HS.txSigHash tx (getRedeemScript cp) 0 serverSigHash where tx = toUnsignedSettlementTx csPayment recvAddr txFee -settlementSigningTxHashFromState :: - PaymentChannelState - -> HC.Address -- ^Receiver destination address - -> BitcoinAmount -- ^Bitcoin transaction fee - -> HC.Hash256 -settlementSigningTxHashFromState cs@(CPaymentChannelState _ cp _ _ _ _ _) = - getSettlementTxHashForSigning (csFromState cs) cp - -getSignedSettlementTx :: - ClientSignedPayment +getSignedSettlementTx + :: ClientSignedPayment -> ChannelParameters -> HC.Address -- ^Receiver/server funds destination address + -> (HC.Hash256 -> HC.Signature) -- ^ Server/receiver's signing function. Produces a signature which verifies against 'cpReceiverPubKey' -> BitcoinAmount -- ^Bitcoin tx fee - -> HC.Signature -- ^Signature over 'getSettlementTxHashForSigning' which verifies against serverPubKey -> HT.Tx getSignedSettlementTx csPayment@(ClientSignedPayment _ clientSig) - cp recvAddr txFee serverRawSig = + cp recvAddr signFunc txFee = let + rawServerSig = signFunc $ getSettlementTxHashForSigning csPayment cp recvAddr txFee unsignedTx = toUnsignedSettlementTx csPayment recvAddr txFee - serverSig = CPaymentSignature serverRawSig serverSigHash + serverSig = CPaymentSignature rawServerSig serverSigHash inputScript = getP2SHInputScript cp $ paymentTxScriptSig clientSig serverSig in replaceScriptInput 0 (serialize inputScript) unsignedTx -signedSettlementTxFromState :: - PaymentChannelState +createSignedSettlementTx + :: HasFee fee + => ClientSignedPayment + -> ChannelParameters + -> HC.Address -- ^Receiver/server funds destination address + -> (HC.Hash256 -> HC.Signature) -- ^Server/receiver's signing function. Produces a signature which verifies against 'cpReceiverPubKey' + -> fee -- ^Bitcoin tx fee + -> HT.Tx +createSignedSettlementTx csp cp addr signFunc fee = + getSignedSettlementTx csp cp addr signFunc (absoluteFee (calcTxSize zeroFeeTx) fee) + where + zeroFeeTx = getSignedSettlementTx csp cp addr signFunc (0 :: BitcoinAmount) + +signedSettlementTxFromState + :: HasFee fee + => PaymentChannelState + -> HC.Address -- ^Receiver/server funds destination address -> (HC.Hash256 -> HC.Signature) -- ^ Server/receiver's signing function. Produces a signature which verifies against 'cpReceiverPubKey' - -> HC.Address -- ^Receiver/server funds destination address - -> BitcoinAmount -- ^Bitcoin tx fee + -> fee -- ^Bitcoin tx fee -> HT.Tx -signedSettlementTxFromState cs@(CPaymentChannelState _ cp _ _ _ _ _) signFunc recvAddr txFee = - getSignedSettlementTx (csFromState cs) cp recvAddr txFee serverSig - where serverSig = signFunc (settlementSigningTxHashFromState cs recvAddr txFee) +signedSettlementTxFromState cs@(CPaymentChannelState _ cp _ _ _ _ _) = + createSignedSettlementTx (cPaymentFromState cs) cp + +cPaymentFromState :: PaymentChannelState -> ClientSignedPayment +cPaymentFromState cs@(CPaymentChannelState _ _ _ _ _ _ clientSig) = + ClientSignedPayment (fromState cs) clientSig diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/State.hs b/src/Data/Bitcoin/PaymentChannel/Internal/State.hs --- a/src/Data/Bitcoin/PaymentChannel/Internal/State.hs +++ b/src/Data/Bitcoin/PaymentChannel/Internal/State.hs @@ -90,13 +90,25 @@ CPaymentChannelState cfg cp fun pconf (payCount+1) newSenderVal . cpSignature <$> checkDustLimit cfg payment +-- |Create a 'ReceiverPaymentChannelX', which has an associated XPubKey, from a +-- 'ReceiverPaymentChannel' +mkExtendedKeyRPC :: ReceiverPaymentChannel -> HC.XPubKey -> Maybe ReceiverPaymentChannelX +mkExtendedKeyRPC (CReceiverPaymentChannel pcs _) xpk = + if xPubKey xpk == getPubKey (pcsServerPubKey pcs) then + Just $ CReceiverPaymentChannel pcs xpk + else + Nothing + checkDustLimit :: Config -> Payment -> Either PayChanError Payment checkDustLimit (Config dustLimit _) payment@(CPayment senderChangeVal _) | senderChangeVal < dustLimit = Left $ DustOutput dustLimit | otherwise = Right payment -isPastLockTimeDate :: UTCTime -> Config -> ChannelParameters -> Bool +isPastLockTimeDate :: UTCTime + -> Config + -> ChannelParameters + -> Bool isPastLockTimeDate currentTime (Config _ settlePeriodHrs) (CChannelParameters _ _ (LockTimeDate expTime)) = currentTime > (settlePeriod `addUTCTime` expTime) where settlePeriod = -1 * fromIntegral (toSeconds settlePeriodHrs) :: NominalDiffTime diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Types.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Types.hs --- a/src/Data/Bitcoin/PaymentChannel/Internal/Types.hs +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Types.hs @@ -1,20 +1,20 @@ {-# LANGUAGE DeriveGeneric, DataKinds #-} - +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeSynonymInstances, FlexibleInstances #-} module Data.Bitcoin.PaymentChannel.Internal.Types ( module Data.Bitcoin.PaymentChannel.Internal.Types , module Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Amount , module Data.Bitcoin.PaymentChannel.Internal.Bitcoin.LockTime + , module Data.Bitcoin.PaymentChannel.Internal.Crypto.PubKey , module Network.Haskoin.Transaction , module Network.Haskoin.Crypto , module Network.Haskoin.Script -) - -where +) where import Data.Bitcoin.PaymentChannel.Internal.Util import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Amount import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.LockTime +import Data.Bitcoin.PaymentChannel.Internal.Crypto.PubKey import Network.Haskoin.Transaction import Network.Haskoin.Crypto @@ -27,14 +27,6 @@ import qualified Data.Tagged as Tag -defaultConfig = Config defaultDustLimit defaultSettlementPeriod - -defaultDustLimit = 700 :: BitcoinAmount -defaultSettlementPeriod = 10 :: Hour - -newtype UnsignedPaymentTx = CUnsignedPaymentTx { unsignedTx :: HT.Tx } deriving Show -type FinalTx = HT.Tx - -- |Shared state object used by both value sender and value receiver. data PaymentChannelState = CPaymentChannelState { -- |Holds various optional configuration options @@ -63,8 +55,8 @@ -- the channel data FundingTxInfo = CFundingTxInfo { ftiHash :: HT.TxHash, -- ^ Hash of funding transaction. - ftiOutIndex :: Word32, -- ^ Index/"vout" of funding output - ftiOutValue :: BitcoinAmount -- ^ Value of funding output (channel max value) + ftiOutIndex :: Word32, -- ^ Index/"vout" of funding output (zero-based index of funding output within list of transaction outputs) + ftiOutValue :: BitcoinAmount -- ^ Value of funding output (channel max value). } deriving (Eq, Show, Typeable) -- |Holds information about how to construct the payment transaction @@ -87,7 +79,7 @@ data Payment = CPayment { -- |Channel value remaining ('pcsValueLeft' of the state from which this payment was made) cpClientChange :: BitcoinAmount - -- |Payment signature + -- |Get payment signature from payment , cpSignature :: PaymentSignature } deriving (Eq, Typeable) @@ -96,8 +88,9 @@ fpPayment :: Payment -- |The payment transaction redeems this outpoint , fpOutPoint :: HT.OutPoint + -- |Using this redeemScript , fpRedeemScript :: HS.Script - -- |Client change output address in the payment tx + -- |Paying this amount to the client/sender change output , fpChangeAddr :: HC.Address } deriving (Eq, Typeable) @@ -111,23 +104,41 @@ -- |Wraps a Network.Haskoin.Script.Script newtype ChanScript = ChanScript { getScript :: HS.Script } deriving (Eq, Show) --- Never confuse sender/receiver pubkey -newtype SendPubKey = MkSendPubKey { - getSenderPK :: HC.PubKey -} deriving (Eq, Show) +type PayChanState = PaymentChannelState +type ChanParams = ChannelParameters -newtype RecvPubKey = MkRecvPubKey { - getReceiverPK :: HC.PubKey -} deriving (Eq, Show) +-- |ReceiverPaymentChannel without public key metadata +type ReceiverPaymentChannel = ReceiverPaymentChannelI () +-- |ReceiverPaymentChannel with BIP32 , "extended" public key metadata +type ReceiverPaymentChannelX = ReceiverPaymentChannelI HC.XPubKey -class IsPubKey a where - getPubKey :: a -> HC.PubKey +-- |State object for the value receiver. pkInfo holds optional, extra +-- data associated with the receiver public key +data ReceiverPaymentChannelI pkInfo = CReceiverPaymentChannel { + -- |Internal state object + rpcState :: PaymentChannelState + , rpcPubKeyInfo :: pkInfo +} deriving (Eq, Typeable) -instance IsPubKey SendPubKey where - getPubKey = getSenderPK -instance IsPubKey RecvPubKey where - getPubKey = getReceiverPK +instance Show ReceiverPaymentChannel where + show (CReceiverPaymentChannel s _) = + "" + +instance Show ReceiverPaymentChannelX where + show (CReceiverPaymentChannel s _) = + "" + + +rpcGetXPub = rpcPubKeyInfo + type Hour = Tag.Tagged "Hour" Word32 toSeconds :: Hour -> Integer toSeconds = fromIntegral . (* 3600) . Tag.unTagged + + +-- Defaults +defaultConfig = Config defaultDustLimit defaultSettlementPeriod + +defaultDustLimit = 700 :: BitcoinAmount +defaultSettlementPeriod = 10 :: Hour diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Util.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Util.hs --- a/src/Data/Bitcoin/PaymentChannel/Internal/Util.hs +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Util.hs @@ -24,9 +24,13 @@ import qualified Data.Text as T import qualified Data.Aeson.Types as JSON import qualified Network.Haskoin.Crypto as HC +import qualified Network.Haskoin.Transaction as HT import Data.String.Conversions (cs) import Data.Text.Encoding (decodeUtf8, encodeUtf8) + +calcTxSize :: HT.Tx -> Word +calcTxSize = fromIntegral . B.length . Bin.encode mapLeft f = either (Left . f) Right mapRight f = either Left (Right . f) diff --git a/src/Data/Bitcoin/PaymentChannel/Test.hs b/src/Data/Bitcoin/PaymentChannel/Test.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitcoin/PaymentChannel/Test.hs @@ -0,0 +1,113 @@ +module Data.Bitcoin.PaymentChannel.Test +( + module Data.Bitcoin.PaymentChannel.Test + , module Data.Bitcoin.PaymentChannel + , module Data.Bitcoin.PaymentChannel.Types + , module Data.Bitcoin.PaymentChannel.Internal.Types + , module Data.Bitcoin.PaymentChannel.Internal.State +) + +where + +import Data.Bitcoin.PaymentChannel +import Data.Bitcoin.PaymentChannel.Types +import Data.Bitcoin.PaymentChannel.Internal.Types +import Data.Bitcoin.PaymentChannel.Util +import Data.Bitcoin.PaymentChannel.Internal.State hiding (channelIsExhausted, channelValueLeft) + +import qualified Network.Haskoin.Crypto as HC +import Network.Haskoin.Test +import Data.Time.Clock (UTCTime(..)) +import Data.Time.Calendar (Day(..)) + +import Test.QuickCheck + + +-- TODO: We don't bother testing expiration time for now +nowishTimestamp :: UTCTime +nowishTimestamp = UTCTime (ModifiedJulianDay 57683) 0 -- 2016-10-22 + +mIN_CHANNEL_SIZE :: BitcoinAmount +mIN_CHANNEL_SIZE = cDustLimit defaultConfig * 2 + + +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 + +instance Arbitrary ArbChannelPair where + arbitrary = fmap fst mkChanPair + +instance Arbitrary PaymentChannelState where + arbitrary = fmap getPCS mkChanPair + where getPCS (ArbChannelPair _ rpc _ _ _ , _) = rpcState rpc + +instance Arbitrary ChanScript where + arbitrary = ChanScript . getRedeemScript <$> arbitrary + +instance Arbitrary FullPayment where + arbitrary = fmap snd mkChanPair + +instance Arbitrary ChannelParameters where + arbitrary = fmap fst mkChanParams + +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) + + +mkChanParams :: Gen (ChannelParameters, (HC.PrvKeyC, HC.PrvKeyC)) +mkChanParams = do + -- sender key pair + ArbitraryPubKeyC sendPriv sendPK <- arbitrary + -- receiver key pair + ArbitraryPubKeyC 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) diff --git a/src/Data/Bitcoin/PaymentChannel/Types.hs b/src/Data/Bitcoin/PaymentChannel/Types.hs --- a/src/Data/Bitcoin/PaymentChannel/Types.hs +++ b/src/Data/Bitcoin/PaymentChannel/Types.hs @@ -8,24 +8,41 @@ -} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeSynonymInstances, FlexibleInstances #-} module Data.Bitcoin.PaymentChannel.Types ( - PaymentChannel(..), - SenderPaymentChannel(..), - ReceiverPaymentChannel(..), + -- *Interface + PaymentChannel(..), PayChan, + + -- *State + SenderPaymentChannel(..), SendPayChan, + ReceiverPaymentChannel, ReceiverPaymentChannelI, RecvPayChan, + ReceiverPaymentChannelX, RecvPayChanX, + + -- *Config Config(..),defaultConfig, + FundingTxInfo(..), + ChannelParameters(..), ChanParams, + + -- *Payment Payment,cpSignature, FullPayment(..), - FundingTxInfo(..), - ChannelParameters(..), - PayChanError(..), - PaymentChannelState, - SendPubKey(..),RecvPubKey(..),IsPubKey(..), - BitcoinAmount, - BitcoinLockTime(..), fromDate, - usesBlockHeight + -- **Error + PayChanError(..) + + -- *Bitcoin +, BitcoinAmount +, BitcoinLockTime(..) +, module Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Fee + + -- *Crypto +, SendPubKey(..),RecvPubKey(..),IsPubKey(..), + + -- *Util + S.mkExtendedKeyRPC, rpcGetXPub, fromDate, usesBlockHeight + +-- PaymentChannelState, ) where @@ -35,6 +52,7 @@ import qualified Data.Bitcoin.PaymentChannel.Internal.State as S import qualified Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Script as Script import Data.Bitcoin.PaymentChannel.Internal.Error (PayChanError(..)) +import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Fee import qualified Data.Serialize as Bin import qualified Network.Haskoin.Crypto as HC @@ -83,22 +101,17 @@ data SenderPaymentChannel = CSenderPaymentChannel { -- |Internal state object spcState :: PaymentChannelState, + -- |Payment-signing function spcSignFunc :: HC.Hash256 -> HC.Signature } --- |State object for the value receiver -newtype ReceiverPaymentChannel = CReceiverPaymentChannel { - -- |Internal state object - rpcState :: PaymentChannelState -} deriving (Eq, Bin.Serialize) - instance PaymentChannel SenderPaymentChannel where valueToMe = channelValueLeft getChannelState = spcState _setChannelState spc s = spc { spcState = s } instance PaymentChannel ReceiverPaymentChannel where - valueToMe rpc@(CReceiverPaymentChannel s) = + valueToMe rpc@(CReceiverPaymentChannel s _) = S.pcsChannelTotalValue s - channelValueLeft rpc getChannelState = rpcState _setChannelState rpc s = rpc { rpcState = s } @@ -107,6 +120,13 @@ show (CSenderPaymentChannel s _) = "" -instance Show ReceiverPaymentChannel where - show (CReceiverPaymentChannel s) = - "" + +-- |Short-hand +type SendPayChan = SenderPaymentChannel +-- |Short-hand +type RecvPayChan = ReceiverPaymentChannel +-- |Short-hand +type RecvPayChanX = ReceiverPaymentChannelX +-- |Short-hand +class PaymentChannel a => PayChan a + diff --git a/src/Data/Bitcoin/PaymentChannel/Util.hs b/src/Data/Bitcoin/PaymentChannel/Util.hs --- a/src/Data/Bitcoin/PaymentChannel/Util.hs +++ b/src/Data/Bitcoin/PaymentChannel/Util.hs @@ -23,7 +23,7 @@ where import Data.Bitcoin.PaymentChannel.Internal.Types - (PaymentChannelState(..), + (PaymentChannelState(..), ReceiverPaymentChannelI(..), Payment(..), PaymentSignature(..)) import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Script (getP2SHFundingAddress, getRedeemScript) @@ -55,9 +55,9 @@ -- |Update internal state without signature verification. -- Useful for database-type services where a logic layer has already -- verified the signature, and it just needs to be stored. -unsafeUpdateRecvState :: ReceiverPaymentChannel -> Payment -> ReceiverPaymentChannel -unsafeUpdateRecvState (CReceiverPaymentChannel s) (CPayment val sig) = - CReceiverPaymentChannel $ s { pcsClientChangeVal = val, pcsPaymentSignature = sig} +unsafeUpdateRecvState :: ReceiverPaymentChannelI a -> Payment -> ReceiverPaymentChannelI a +unsafeUpdateRecvState (CReceiverPaymentChannel s pki) (CPayment val sig) = + CReceiverPaymentChannel ( s { pcsClientChangeVal = val, pcsPaymentSignature = sig} ) pki fpGetSig :: FullPayment -> HC.Signature fpGetSig = psSig . cpSignature . fpPayment diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,36 +1,19 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - module Main where - -import Data.Bitcoin.PaymentChannel -import Data.Bitcoin.PaymentChannel.Types +import Data.Bitcoin.PaymentChannel.Test 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 @@ -53,33 +36,35 @@ 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 + [ testGroup "JSON" + [ testProperty "FullPayment" + (jsonSerDeser :: FullPayment -> Bool) + ] + , testGroup "Binary" + [ testProperty "FullPayment" + (binSerDeser :: FullPayment -> Bool) + , testProperty "PaymentChannelState" + (binSerDeser :: PaymentChannelState -> Bool) + , testProperty "ChanScript" + (binSerDeser :: ChanScript -> Bool) + ] ] ] -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 settleTx = getSettlementBitcoinTx recvChan testAddrLivenet recvSignFunc (0 :: BitcoinAmount) 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) - + let fundAmountMinusPaySum = 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 settleTx = getSettlementBitcoinTx recvChan testAddrLivenet recvSignFunc (0 :: BitcoinAmount) let receiverAmount = HT.outValue (HT.txOut settleTx !! 1) -- Check receiver amount in settlement transaction with zero fee equals sum -- of all payments. @@ -129,82 +114,3 @@ 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)