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.2.3.1 +version: 0.3.0.0 synopsis: Library for working with Bitcoin payment channels description: A Bitcoin payment channel allows secure and instant transfer of bitcoins from one @@ -33,28 +33,27 @@ library exposed-modules: Data.Bitcoin.PaymentChannel, Data.Bitcoin.PaymentChannel.Types, - Data.Bitcoin.PaymentChannel.Util + Data.Bitcoin.PaymentChannel.Util, + -- Exposed for testing purposes + Data.Bitcoin.PaymentChannel.Internal.State - other-modules: - Data.Bitcoin.PaymentChannel.Internal.Error - Data.Bitcoin.PaymentChannel.Internal.BitcoinAmount, + other-modules: Data.Bitcoin.PaymentChannel.Internal.Error Data.Bitcoin.PaymentChannel.Internal.Payment, Data.Bitcoin.PaymentChannel.Internal.Refund, - Data.Bitcoin.PaymentChannel.Internal.State, - Data.Bitcoin.PaymentChannel.Internal.Script, + 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.Settlement, Data.Bitcoin.PaymentChannel.Internal.Types, Data.Bitcoin.PaymentChannel.Internal.Serialization, - Data.Bitcoin.PaymentChannel.Internal.Util, - Data.Bitcoin.PaymentChannel.Internal.Version - + Data.Bitcoin.PaymentChannel.Internal.Util ghc-options: -W build-depends: base >= 4.7 && < 5, - haskoin-core >= 0.3.1 && < 0.4.0, + haskoin-core >= 0.4.0 && < 0.5.0, base16-bytestring >= 0.1.0 && < 0.2.0, - base58string >= 0.10.0 && < 0.11.0, base64-bytestring >= 1.0.0 && < 1.1.0, binary >= 0.7.0 && < 0.9.0, bytestring >= 0.10.0 && < 0.11.0, @@ -73,11 +72,7 @@ executable Test main-is: Main.hs --- default-extensions: FlexibleContexts - --- other-modules: - --- ghc-options: -Wall + ghc-options: -W build-depends: base >= 4.7 && < 5, haskoin-core >= 0.3.0 && < 1.0.0, 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 @@ -95,29 +95,23 @@ ) where -import Data.Bitcoin.PaymentChannel.Internal.Error - (PayChanError(..)) import Data.Bitcoin.PaymentChannel.Internal.Types - (PaymentTxConfig(..), pcsValueLeft, cpChannelValueLeft) + (PaymentTxConfig(..), Payment(..), pcsValueLeft) import Data.Bitcoin.PaymentChannel.Internal.State (newPaymentChannelState, updatePaymentChannelState) import qualified Data.Bitcoin.PaymentChannel.Internal.State as S - (channelValueLeft) import Data.Bitcoin.PaymentChannel.Internal.Payment - (createPayment, verifyPaymentSig) + (createPayment, paymentFromState, verifyPaymentSigFromState) import Data.Bitcoin.PaymentChannel.Internal.Settlement - (getSignedSettlementTx, getSettlementTxHashForSigning) + (signedSettlementTxFromState) import Data.Bitcoin.PaymentChannel.Internal.Refund (refundTxAddSignature, getRefundTxHashForSigning) -import Data.Bitcoin.PaymentChannel.Internal.Util - (bitcoinPayPKBS, mapRight) import Data.Bitcoin.PaymentChannel.Util (getFundingAddress) import Data.Bitcoin.PaymentChannel.Types import qualified Network.Haskoin.Crypto as HC import qualified Network.Haskoin.Transaction as HT -import qualified Network.Haskoin.Script as HS -- |Create a new 'SenderPaymentChannel'. @@ -125,36 +119,41 @@ -- the channel and the funding transaction, as well as the value of the first payment. -- Returns a new 'SenderPaymentChannel' state object and the first channel payment. channelWithInitialPaymentOf :: - ChannelParameters -- ^ Specifies channel sender and receiver, plus channel expiration date - -> FundingTxInfo -- ^ Holds information about the transaction used to fund the channel - -> (HC.Hash256 -> HC.Signature) -- ^ See 'spcSignFunc' - -> HC.Address -- ^ Value sender/client change address - -> BitcoinAmount -- ^ Value of initial payment. Must be greater than or equal to 'minimumInitialPayment' - -> (Payment, SenderPaymentChannel) -- ^Initial payment and new sender state object -channelWithInitialPaymentOf - cp@(CChannelParameters sendPK recvPK _) - fundInf@(CFundingTxInfo hash idx chanVal) signFunc sendAddr amount = - let pConf = CPaymentTxConfig sendAddr in - sendPayment - (CSenderPaymentChannel (newPaymentChannelState cp fundInf pConf) signFunc) - amount + ChannelParameters -- ^ Specifies channel sender and receiver, channel expiration date and "dust limit" + -> FundingTxInfo -- ^ Holds information about the 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.Address -- ^ Value sender/client change address + -> BitcoinAmount -- ^ Value of initial payment. Must be greater than or equal to 'minimumInitialPayment' + -> (BitcoinAmount, Payment, SenderPaymentChannel) -- ^Initial payment amount (may be capped), initial payment, and new sender state object +channelWithInitialPaymentOf cp fundInf signFunc sendAddr amount = + let pConf = CPaymentTxConfig sendAddr + (CPayment _ tmpSig) = createPayment cp fundInf sendAddr amount signFunc + in + flip sendPayment amount $ CSenderPaymentChannel + (newPaymentChannelState cp fundInf pConf tmpSig) signFunc -- |Create new payment of specified value. sendPayment :: - SenderPaymentChannel -- ^Sender state object - -> BitcoinAmount -- ^ Amount to send (the actual payment amount is capped so that it doesn't overflow the maximum channel value) - -> (Payment, SenderPaymentChannel) -- ^ Payment and updated sender state object + SenderPaymentChannel -- ^Sender state object + -> BitcoinAmount -- ^ Amount to send (the actual payment amount is capped so that that, at minimu, the client change value equals the dust limit) + -> (BitcoinAmount, Payment, SenderPaymentChannel) -- ^ Actual amount sent, payment, and updated sender state object sendPayment (CSenderPaymentChannel cs signFunc) amountToSend = let - valSent = min (pcsValueLeft cs) amountToSend - newSenderValue = pcsValueLeft cs - valSent - payment = createPayment cs newSenderValue signFunc + valSent = pcsValueLeft cs - newSenderValue + newSenderValue = max (S.pcsDustLimit cs) (pcsValueLeft cs - amountToSend) + payment = paymentFromState cs newSenderValue signFunc in case updatePaymentChannelState cs payment of Right newCS -> - (payment + (valSent + ,payment ,CSenderPaymentChannel newCS signFunc) - Left _ -> error "BUG: 'createPayment' created value-backtracking tx" + Left (BadPaymentValue val) -> + error $ "BUG: 'createPayment' created value-backtracking tx of" ++ show val + Left DustOutput -> + error "BUG: 'createPayment' created dust output" + Left e -> + error $ "BUG: 'updatePaymentChannelState' returned unknown error: " ++ show e -- |Produces a Bitcoin transaction which sends all channel funds back to the sender. -- Will not be accepted by the Bitcoin network until the expiration time specified in @@ -178,13 +177,13 @@ -> HC.Address -- ^ Value sender/client change address -> Payment -- ^Initial channel payment -> Either PayChanError (BitcoinAmount, ReceiverPaymentChannel) -- ^Error or: value_received plus state object -channelFromInitialPayment cp@(CChannelParameters sendPK recvPK _) - fundInf sendAddr paymnt = +channelFromInitialPayment cp fundInf sendAddr payment@(CPayment _ sig) = let pConf = CPaymentTxConfig sendAddr in - flip recvPayment paymnt $ CReceiverPaymentChannel - (newPaymentChannelState cp fundInf pConf) + flip recvPayment payment $ CReceiverPaymentChannel + -- Create a new state with the unverified signature; then verify the same signature in 'recvPayment' + (newPaymentChannelState 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 @@ -194,15 +193,17 @@ -> Payment -- ^Payment to verify and register -> Either PayChanError (BitcoinAmount, ReceiverPaymentChannel) -- ^Value received plus new receiver state object recvPayment rpc@(CReceiverPaymentChannel oldState) paymnt = - let verifySenderPayment hash pk sig = HC.verifySig hash sig (getPubKey pk) in - if verifyPaymentSig oldState paymnt verifySenderPayment then - updatePaymentChannelState oldState paymnt >>= - (\newState -> Right ( - S.channelValueLeft oldState - S.channelValueLeft newState - , rpc { rpcState = newState }) - ) - else - Left BadSignature + let + verifySenderPayment hash pk sig = HC.verifySig hash sig (getPubKey pk) + in + if verifyPaymentSigFromState oldState verifySenderPayment paymnt then + updatePaymentChannelState oldState paymnt >>= + (\newState -> Right ( + S.channelValueLeft oldState - S.channelValueLeft newState + , rpc { rpcState = newState }) + ) + else + Left SigVerifyFailed -- |The value transmitted over the channel is settled when this transaction is in the Blockchain. @@ -210,19 +211,13 @@ -- 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. --- Returns NoValueTransferred if no payment has been received yet. getSettlementBitcoinTx :: - ReceiverPaymentChannel -- ^Receiver state object - -> (HC.Hash256 -> HC.Signature) -- ^ Function which produces a signature, over a hash, which verifies against 'cpReceiverPubKey' - -> HC.Address - -> BitcoinAmount -- ^Bitcoin transaction fee - -> HT.Tx -- ^Settling Bitcoin transaction -getSettlementBitcoinTx (CReceiverPaymentChannel cs) signFunc recvAddr txFee = - nothingThrowInternal $ getSignedSettlementTx cs recvAddr txFee serverSig - where serverSig = signFunc (getSettlementTxHashForSigning cs recvAddr txFee) - nothingThrowInternal Nothing = error $ - "tried to produce settlement transaction without any payments in state." ++ - " this should not be possible via the library interface." - nothingThrowInternal (Just tx) = tx + ReceiverPaymentChannel -- ^ Receiver state object + -> (HC.Hash256 -> HC.Signature) -- ^ Function which produces a signature which verifies against 'cpReceiverPubKey' + -> 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 + -> HT.Tx -- ^ Settling Bitcoin transaction +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 new file mode 100644 --- /dev/null +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Amount.hs @@ -0,0 +1,58 @@ +module Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Amount where + +import qualified Data.Serialize as Ser +import qualified Data.Serialize.Put as SerPut +import qualified Data.Serialize.Get as SerGet +import qualified Data.Binary as Bin +import qualified Data.Binary.Put as BinPut +import qualified Data.Binary.Get as BinGet +import Data.Word + + +-- |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. +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) + abs = id -- Always positive + signum (BitcoinAmount 0) = BitcoinAmount 0 + signum (BitcoinAmount _) = BitcoinAmount 1 + fromInteger = BitcoinAmount . fromIntegral . capToWord64 + +instance Enum BitcoinAmount where + toEnum = BitcoinAmount . fromIntegral . capToWord64 . fromIntegral + fromEnum (BitcoinAmount amount) = fromIntegral amount + +instance Real BitcoinAmount where + toRational (BitcoinAmount amount) = toRational amount + +instance Integral BitcoinAmount where + toInteger (BitcoinAmount int) = int + quotRem (BitcoinAmount _) (BitcoinAmount _) = + error "Division of two BitcoinAmounts is undefined" + +-- | Convert to 'Word64', with zero as floor, (maxBound :: Word64) as ceiling +capToWord64 :: Integer -> Word64 +capToWord64 i = fromIntegral $ + max 0 cappedValue + where + cappedValue = min i $ fromIntegral (maxBound :: Word64) + +instance Bin.Binary BitcoinAmount where + put = BinPut.putWord64le . fromIntegral . toInteger + get = BitcoinAmount . fromIntegral <$> BinGet.getWord64le + +instance Ser.Serialize BitcoinAmount where + put = SerPut.putWord64le . fromIntegral . toInteger + get = BitcoinAmount . fromIntegral <$> SerGet.getWord64le diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/LockTime.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/LockTime.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/LockTime.hs @@ -0,0 +1,48 @@ +module Data.Bitcoin.PaymentChannel.Internal.Bitcoin.LockTime where + +import Data.Word (Word32) +import qualified Data.Serialize as Bin +import Data.Serialize.Put (putWord32le) +import Data.Serialize.Get (getWord32le) +import Data.Time.Clock +import Data.Time.Clock.POSIX +import Data.Typeable +import Data.Time.Format () -- instance Show UTCTime + +-- |Data type representing a Bitcoin LockTime, which specifies a point in time. +-- Derive a 'BitcoinLockTime' from a 'Data.Time.Clock.UTCTime' using 'fromDate'. +data BitcoinLockTime = + -- |A value of "n" represents the point in time at which Bitcoin block number "n" appears + LockTimeBlockHeight Word32 | + -- |Specifies a point in time using a timestamp with 1-second accuracy + LockTimeDate UTCTime deriving (Eq, Ord, Typeable) + +instance Show BitcoinLockTime where + show (LockTimeBlockHeight blockNum) = "block number " ++ show blockNum + show (LockTimeDate date) = show date + +instance Bin.Serialize BitcoinLockTime where + put = putWord32le . toWord32 + get = parseBitcoinLocktime <$> getWord32le + +-- | Convert from Bitcoin format ('Word32') +parseBitcoinLocktime :: Word32 -> BitcoinLockTime +parseBitcoinLocktime i + | i < 500000000 = LockTimeBlockHeight i + | i >= 500000000 = LockTimeDate $ posixSecondsToUTCTime (fromIntegral i) + | otherwise = error "GHC bug?" + +-- | Convert to Bitcoin format ('Word32') +toWord32 :: BitcoinLockTime -> Word32 +toWord32 (LockTimeBlockHeight i) = i +toWord32 (LockTimeDate date) = + fromIntegral . round . utcTimeToPOSIXSeconds $ date + +-- | Convert a 'Data.Time.Clock.UTCTime' to a 'BitcoinLockTime' +fromDate :: UTCTime -> BitcoinLockTime +fromDate = LockTimeDate + +usesBlockHeight :: BitcoinLockTime -> Bool +usesBlockHeight (LockTimeBlockHeight _) = True +usesBlockHeight _ = False + diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Script.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Script.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Script.hs @@ -0,0 +1,76 @@ +-- {-# OPTIONS_GHC -fwarn-incomplete-patterns -Werror #-} + +module Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Script where + +import Data.Bitcoin.PaymentChannel.Internal.Types +import Data.Bitcoin.PaymentChannel.Internal.Serialization () +import Data.Bitcoin.PaymentChannel.Internal.Util + +import qualified Network.Haskoin.Internals as HI +import qualified Network.Haskoin.Crypto as HC +import Network.Haskoin.Script + (Script(..), SigHash(..), ScriptOp(..), opPushData) + +import qualified Data.ByteString as B + +valReceiverSigHash = SigAll True + +-- |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 clientPK serverPK lockTime = + let + -- Note: HI.encodeInt encodes values up to and including 2^31-1 as 4 bytes + -- and values 2^31 through 2^32-1 (upper limit) as 5 bytes. + encodeScriptInt = B.pack . HI.encodeInt . fromIntegral . toWord32 + serverPubKey = getPubKey serverPK + clientPubKey = getPubKey clientPK + in Script + [OP_IF, + opPushData $ serialize serverPubKey, OP_CHECKSIGVERIFY, + OP_ELSE, + opPushData $ encodeScriptInt lockTime, op_CHECKLOCKTIMEVERIFY, OP_DROP, + OP_ENDIF, + opPushData $ serialize clientPubKey, OP_CHECKSIG] + + + +-- |scriptSig fulfilling 'paymentChannelRedeemScript' using two signatures (client+server) +paymentTxScriptSig :: PaymentSignature -> PaymentSignature -> Script --ScriptSig +paymentTxScriptSig clientSig serverSig = Script + [opPushData $ serialize clientSig, --sig including SigHash byte + opPushData $ serialize serverSig, --sig including SigHash byte + OP_1] -- Signal that we want to provide both PubKeys + +-- |scriptSig fulfilling 'paymentChannelRedeemScript' using a single signature (client) +-- (not valid until specified lockTime) +refundTxScriptSig :: HC.Signature -> Script +refundTxScriptSig clientSig = Script + [opPushData (B.append (serialize clientSig) hashTypeByte), + OP_0] -- Signal that we want to provide only one PubKey + where hashTypeByte = serialize (SigAll False) + +-----Util----- + +op_CHECKLOCKTIMEVERIFY = OP_NOP2 + +scriptToP2SHAddress :: Script -> HC.Address +scriptToP2SHAddress = HC.ScriptAddress . HC.hash160 . HC.getHash256 . HC.hash256 . serialize + +getP2SHFundingAddress :: ChannelParameters -> HC.Address +getP2SHFundingAddress = scriptToP2SHAddress . getRedeemScript + +getRedeemScript :: ChannelParameters -> Script +getRedeemScript (CChannelParameters senderPK recvrPK lockTime _) = + paymentChannelRedeemScript senderPK recvrPK lockTime + +getRedeemScriptBS :: ChannelParameters -> B.ByteString +getRedeemScriptBS = serialize . getRedeemScript + +getP2SHInputScript :: ChannelParameters -> Script -> Script +getP2SHInputScript cp scriptSig = + Script $ scriptOps scriptSig ++ redeemScript + where + redeemScript = [opPushData $ getRedeemScriptBS cp] + diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Util.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Util.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Util where + + +import qualified Data.Serialize as Ser +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C +import qualified Network.Haskoin.Transaction as HT +import qualified Network.Haskoin.Util as HU +import qualified Network.Haskoin.Script as HS +import qualified Network.Haskoin.Crypto as HC +import Data.Word (Word32) + + +-- | Converts a pay-to-pubkey-hash address string to Script. +-- | Eg. \"1PDGytNA7EJ5XrJdTGKv11VAUFxKnsfwke\" into +-- | \"Script [OP_DUP, OP_HASH160, OP_PUSHDATA f3a5194fbf4b3556838e0f773b613a876737a2c6, +-- | OP_EQUALVERIFY, OP_CHECKSIG]\" +p2PKAddressToScript :: String -> Maybe HS.Script +p2PKAddressToScript addrStr = + HS.encodeOutput . HS.PayPKHash <$> HC.base58ToAddr (C.pack addrStr) + +-- | Converts a pay-to-script-hash address string to Script. +-- | Eg. \"2PDGytNA7EJ5XrJdTGKv11VAUFxKnsfwke\" +p2SHAddressToScript :: String -> Maybe HS.Script +p2SHAddressToScript addrStr = + HS.encodeOutput . HS.PayScriptHash <$> HC.base58ToAddr (C.pack addrStr) + +addressToScript :: HC.Address -> HS.ScriptOutput +addressToScript addr = + case addr of + a@(HC.PubKeyAddress _) -> HS.PayPKHash a + a@(HC.ScriptAddress _) -> HS.PayScriptHash a + +addressToScriptPubKeyBS :: HC.Address -> B.ByteString +addressToScriptPubKeyBS = HS.encodeOutputBS . addressToScript + +replaceScriptInput :: Word32 -> B.ByteString -> HT.Tx -> HT.Tx +replaceScriptInput index scriptIn tx = + HT.createTx (HT.txVersion tx) newTxIns (HT.txOut tx) (HT.txLockTime tx) + where newTxIns = HU.updateIndex (fromIntegral index) (HT.txIn tx) replaceScriptIn + replaceScriptIn txIn = txIn { HT.scriptInput = scriptIn} + +removeOutputs :: HT.Tx -> HT.Tx +removeOutputs tx = + HT.createTx (HT.txVersion tx) (HT.txIn tx) [] (HT.txLockTime tx) + +appendOutput :: HT.Tx -> HT.TxOut -> HT.Tx +appendOutput tx txOut = + HT.createTx (HT.txVersion tx) (HT.txIn tx) ( oldOuts ++ [txOut] ) (HT.txLockTime tx) + where oldOuts = HT.txOut tx + +bitcoinPayPK :: HC.PubKey -> 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/BitcoinAmount.hs b/src/Data/Bitcoin/PaymentChannel/Internal/BitcoinAmount.hs deleted file mode 100644 --- a/src/Data/Bitcoin/PaymentChannel/Internal/BitcoinAmount.hs +++ /dev/null @@ -1,61 +0,0 @@ -module Data.Bitcoin.PaymentChannel.Internal.BitcoinAmount where - -import qualified Data.Serialize as Ser -import qualified Data.Serialize.Put as SerPut -import qualified Data.Serialize.Get as SerGet -import qualified Data.Binary as Bin -import qualified Data.Binary.Put as BinPut -import qualified Data.Binary.Get as BinGet -import Data.Word - - --- |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. -newtype BitcoinAmount = BitcoinAmount Integer - deriving (Eq, Ord) -instance Show BitcoinAmount where - show amount = show (toInteger amount) ++ " satoshi" - -instance Num BitcoinAmount where - -- We leave multiplication of two money amounts as undefined - (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) - abs = id -- Always positive - signum (BitcoinAmount 0) = BitcoinAmount 0 - signum (BitcoinAmount _) = BitcoinAmount 1 - fromInteger = BitcoinAmount . fromIntegral . capToWord64 - -instance Enum BitcoinAmount where - toEnum = BitcoinAmount . fromIntegral . capToWord64 . fromIntegral - fromEnum (BitcoinAmount amount) = fromIntegral amount - -instance Real BitcoinAmount where - toRational (BitcoinAmount amount) = toRational amount - -instance Integral BitcoinAmount where - toInteger (BitcoinAmount int) = int - -- Dividing one money amounts by another doesn't make sense either - quotRem (BitcoinAmount _) (BitcoinAmount _) = - error "Division of two BitcoinAmounts is undefined" - --- | Convert to 'Word64', with zero as floor, (maxBound :: Word64) as ceiling -capToWord64 :: Integer -> Word64 -capToWord64 i = fromIntegral $ - max 0 cappedValue - where - cappedValue = min i $ fromIntegral (maxBound :: Word64) - -instance Bin.Binary BitcoinAmount where - put = BinPut.putWord64le . fromIntegral . toInteger - get = BitcoinAmount . fromIntegral <$> BinGet.getWord64le - -instance Ser.Serialize BitcoinAmount where - put = SerPut.putWord64le . fromIntegral . toInteger - get = BitcoinAmount . fromIntegral <$> SerGet.getWord64le - 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 @@ -3,18 +3,15 @@ import Data.Bitcoin.PaymentChannel.Internal.Types (BitcoinAmount) data PayChanError = - BadSignature | + SigVerifyFailed | BadPaymentValue BitcoinAmount | - NoValueTransferred | DustOutput | InternalError String instance Show PayChanError where - show BadSignature = "signature verification failed" + show SigVerifyFailed = "signature verification failed" show (BadPaymentValue valDiff) = - "out-of-order payment (assigns " ++ show valDiff ++ " less value to server)" + "out-of-order payment (assigns " ++ show valDiff ++ " less value to receiver)" show DustOutput = "dust output in payment transaction" - show NoValueTransferred = "cannot create payment Bitcoin transaction: no\ - \ value has been transferred yet" show (InternalError e) = "Internal error: " ++ e diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Payment.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Payment.hs --- a/src/Data/Bitcoin/PaymentChannel/Internal/Payment.hs +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Payment.hs @@ -2,93 +2,120 @@ module Data.Bitcoin.PaymentChannel.Internal.Payment where import Data.Bitcoin.PaymentChannel.Internal.Types -import Data.Bitcoin.PaymentChannel.Internal.State -import Data.Bitcoin.PaymentChannel.Internal.Script +import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Script import Data.Bitcoin.PaymentChannel.Internal.Util -import Data.Bitcoin.PaymentChannel.Internal.Error import qualified Network.Haskoin.Transaction as HT -import qualified Network.Haskoin.Internals as HI import qualified Network.Haskoin.Crypto as HC import qualified Network.Haskoin.Script as HS -import Data.Word (Word32, Word64, Word8) -import Data.Maybe (fromJust, isJust) import qualified Data.ByteString as B ----Payment Tx builer--- -buildEmptyPaymentTx :: FundingTxInfo -> HT.Tx -buildEmptyPaymentTx (CFundingTxInfo hash idx _) = - HT.Tx 1 --version 1 - -- Redeems payment channel output from blockchain Tx - [HT.TxIn - (HT.OutPoint hash idx) - B.empty - maxBound] - [] --no outputs - 0 --lockTime 0 -paymentTxAddOutput :: HT.TxOut -> HT.Tx -> (HT.Tx, HS.SigHash) -paymentTxAddOutput addOut tx@(HT.Tx _ _ outs _) - | HT.outValue addOut >= fromIntegral dUST_LIMIT = - (tx { HT.txOut = outs ++ [addOut] }, HS.SigSingle True) - | otherwise = - (tx, HS.SigNone True) ----Payment Tx builer--- +-- |Represents a P2SH ANYONECANPAY input/output pair from a payment channel. +data UnsignedPayment = UnsignedPayment + { fundingOutPoint :: HT.OutPoint + , outPointValue :: BitcoinAmount + , redeemScript :: HS.Script + , changeAddress :: HC.Address + , changeValue :: BitcoinAmount + } +-- |Contains ncessary data, except receiver signature, to construct a transaction. +data ClientSignedPayment = ClientSignedPayment + { funds :: UnsignedPayment + , clientSig :: PaymentSignature + } -getPaymentTxForSigning :: - PaymentChannelState - -> BitcoinAmount -- ^New sender value (newValueLeft) - -> (HT.Tx, HS.SigHash) -getPaymentTxForSigning st@(CPaymentChannelState _ fti - (CPaymentTxConfig sendAddr) chanValLeft _) newValueLeft = - paymentTxAddOutput senderOut $ buildEmptyPaymentTx fti - where senderOut = HT.TxOut (fromIntegral . toInteger $ newValueLeft) (addressToScriptPubKeyBS sendAddr) +fromState :: PaymentChannelState -> UnsignedPayment +fromState (CPaymentChannelState cp (CFundingTxInfo hash idx fundingVal) + (CPaymentTxConfig changeAddr) changeValue _) = + UnsignedPayment + (HT.OutPoint hash idx) fundingVal + (getRedeemScript cp) changeAddr changeValue -getPaymentTxHashForSigning :: - PaymentChannelState - -> BitcoinAmount -- ^New sender value (newValueLeft) - -> (HC.Hash256, HS.SigHash) -- ^Hash of payment transaction with a single output paying to senderPK -getPaymentTxHashForSigning st@(CPaymentChannelState cp _ _ _ _) newValueLeft = - (HS.txSigHash tx (getRedeemScript cp) 0 sigHash, sigHash) - where (tx,sigHash) = getPaymentTxForSigning st newValueLeft +toUnsignedBitcoinTx :: UnsignedPayment -> HT.Tx +toUnsignedBitcoinTx (UnsignedPayment fundingOutPoint _ _ changeAddr changeVal) = + HT.createTx + 1 --version 1 + -- Redeems payment channel output from blockchain Tx + [HT.TxIn + fundingOutPoint + B.empty + maxBound] + [senderOut] -- change output + 0 --lockTime 0 + where senderOut = HT.TxOut + (fromIntegral . toInteger $ changeVal) + (addressToScriptPubKeyBS changeAddr) ----Payment build/verify--- -verifyPaymentSig :: +getHashForSigning :: UnsignedPayment -> HS.SigHash -> HC.Hash256 +getHashForSigning up@(UnsignedPayment _ _ redeemScript _ _) = + HS.txSigHash + (toUnsignedBitcoinTx up) + redeemScript + 0 -- In the tx we construct using 'toUnsignedBitcoinTx', + -- the input in question is always at index 0 + +---Payment create/verify--- +-- |Create payment, from state. No check of value is performed. +paymentFromState :: PaymentChannelState + -> BitcoinAmount -- ^ sender change value (subtract 'n' from current sender change value to get payment of value 'n') + -> (HC.Hash256 -> HC.Signature) -- ^ signing function -> Payment +paymentFromState (CPaymentChannelState cp fti (CPaymentTxConfig changeAddr) _ _) = + createPayment cp fti changeAddr + +-- |Create payment, pure. +createPayment :: + ChannelParameters + -> FundingTxInfo + -> HC.Address + -> BitcoinAmount -- ^ sender change value (subtract 'n' from current sender change value to get payment of value 'n') + -> (HC.Hash256 -> HC.Signature) -- ^ signing function + -> Payment --ClientSignedPayment +createPayment cp (CFundingTxInfo hash idx val) changeAddr changeVal signFunc = + let + unsignedPayment = UnsignedPayment + (HT.OutPoint hash idx) val (getRedeemScript cp) + changeAddr changeVal + sigHash = if changeVal /= 0 then HS.SigSingle True else HS.SigNone True + hashToSign = getHashForSigning unsignedPayment sigHash + sig = signFunc hashToSign + in + CPayment changeVal (CPaymentSignature sig sigHash) + -- ClientSignedPayment unsignedPayment (CPaymentSignature sig sigHash) + +verifyPaymentSig :: + ChannelParameters + -> FundingTxInfo + -> HC.Address + -> SendPubKey -> (HC.Hash256 -> SendPubKey -> HC.Signature -> Bool) + -> Payment -> Bool -verifyPaymentSig pcs - (CPayment newSenderVal (CPaymentSignature sig sigHash)) verifyFunc = - let (hash,_) = case sigHash of --SigHash in signature overrides newSenderVal - HS.SigSingle True -> getPaymentTxHashForSigning pcs newSenderVal +verifyPaymentSig cp (CFundingTxInfo fundTxId idx val) changeAddr sendPK verifyFunc + (CPayment newSenderVal (CPaymentSignature sig sigHash)) = + let + payProxy = UnsignedPayment + (HT.OutPoint fundTxId idx) val (getRedeemScript cp) + changeAddr newSenderVal + hash = case sigHash of + HS.SigSingle True -> getHashForSigning payProxy sigHash --sender has relinquished remaining channel value - HS.SigNone True -> getPaymentTxHashForSigning pcs 0 - unknownSigHash -> (dummyHash256,sigHash) --will fail verification + HS.SigNone True -> getHashForSigning payProxy sigHash + _ -> dummyHash256 --will fail verification in - verifyFunc hash (pcsClientPubKey pcs) sig + verifyFunc hash sendPK sig -createPayment :: +verifyPaymentSigFromState :: PaymentChannelState - -> BitcoinAmount -- ^ newSenderVal - -> (HC.Hash256 -> HC.Signature) -- ^ signing function + -> (HC.Hash256 -> SendPubKey -> HC.Signature -> Bool) -> Payment -createPayment pcs@(CPaymentChannelState _ _ _ currSenderVal _) - newSenderVal signFunc = - let - (hash,sigHash) = getPaymentTxHashForSigning pcs newSenderVal - sig = signFunc hash - pSig = CPaymentSignature sig sigHash - in - case sigHash of - HS.SigSingle _ -> CPayment newSenderVal pSig - --sender has reliquished the remaining channel value, - -- due to it being below the "dust" limit. - HS.SigNone _ -> CPayment 0 pSig - _ -> error - "BUG: unsupported SigHash created by 'getPaymentTxHashForSigning'" ----Payment build/verify--- + -> Bool +verifyPaymentSigFromState (CPaymentChannelState cp fti (CPaymentTxConfig changeAddr) _ _) = + verifyPaymentSig cp fti changeAddr (cpSenderPubKey cp) +---Payment create/verify--- 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 @@ -2,7 +2,7 @@ import Data.Bitcoin.PaymentChannel.Internal.Types import Data.Bitcoin.PaymentChannel.Internal.State -import Data.Bitcoin.PaymentChannel.Internal.Script +import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Script import Data.Bitcoin.PaymentChannel.Internal.Payment import Data.Bitcoin.PaymentChannel.Internal.Util @@ -13,22 +13,23 @@ getUnsignedRefundTx :: PaymentChannelState -> BitcoinAmount -> HT.Tx getUnsignedRefundTx st txFee = -- @CPaymentChannelState = let - (baseTx,_) = getPaymentTxForSigning st 0 --create empty payment tx, which redeems funding tx + baseTx = toUnsignedBitcoinTx $ fromState st --create empty payment tx, which redeems funding tx refundOut = HT.TxOut (fromIntegral . toInteger $ pcsChannelTotalValue st - txFee) (pcsClientChangeScriptPubKey st) txInput0 = head $ HT.txIn baseTx in - baseTx { - HT.txOut = [refundOut], + HT.createTx + (HT.txVersion baseTx) + -- if the sequence field equals maxBound (0xffffffff) + -- lockTime features are disabled, so we subtract one + [ txInput0 { HT.txInSequence = maxBound-1 } ] + [refundOut] -- lockTime of refund tx must be greater than or equal to the lockTime -- in the channel redeemScript - HT.txLockTime = toWord32 (pcsLockTime st), - -- if the sequence field equals maxBound (0xffffffff), - -- lockTime features are disabled, so we set it to that minus one - HT.txIn = [ txInput0 { HT.txInSequence = maxBound-1 } ] -} + (toWord32 $ pcsLockTime st) + getRefundTxHashForSigning :: PaymentChannelState -> BitcoinAmount -- ^Bitcoin transaction fee @@ -44,7 +45,7 @@ -> FinalTx refundTxAddSignature pcs@(CPaymentChannelState cp _ _ _ _) txFee clientRawSig = let - inputScript = getInputScript cp $ refundTxScriptSig clientRawSig + inputScript = getP2SHInputScript cp $ refundTxScriptSig clientRawSig in - replaceScriptInput (serialize inputScript) $ getUnsignedRefundTx pcs txFee + replaceScriptInput 0 (serialize inputScript) $ getUnsignedRefundTx pcs txFee diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Script.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Script.hs deleted file mode 100644 --- a/src/Data/Bitcoin/PaymentChannel/Internal/Script.hs +++ /dev/null @@ -1,84 +0,0 @@ --- {-# OPTIONS_GHC -fwarn-incomplete-patterns -Werror #-} - -module Data.Bitcoin.PaymentChannel.Internal.Script where - -import Data.Bitcoin.PaymentChannel.Internal.Types -import Data.Bitcoin.PaymentChannel.Internal.Serialization -import Data.Bitcoin.PaymentChannel.Internal.Util - -import qualified Network.Haskoin.Internals as HI -import qualified Network.Haskoin.Util as HU -import qualified Network.Haskoin.Crypto as HC -import Network.Haskoin.Script - (Script(..), SigHash(..), ScriptOp(..), opPushData) - -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as C -import qualified Data.ByteString.Lazy as BL -import qualified Data.Binary as Bin -import Data.Word -import Data.Char as CH - -valReceiverSigHash = SigAll True - -getSigHashFlag :: BitcoinAmount -> SigHash -getSigHashFlag valueToSender = - if valueToSender == 0 then - SigNone True - else - SigSingle True - -sigHashToByte :: SigHash -> Word8 -sigHashToByte = fromIntegral . ord . head . C.unpack . serialize - --- |Generates OP_CHECKLOCKTIMEVERIFY redeemScript -paymentChannelRedeemScript :: SendPubKey -> RecvPubKey -> Word32 -> Script -paymentChannelRedeemScript clientPK serverPK lockTime = Script - [OP_IF, - opPushData $ serialize (getPubKey serverPK), OP_CHECKSIGVERIFY, - OP_ELSE, - encodeScriptInt lockTime, op_CHECKLOCKTIMEVERIFY, OP_DROP, - OP_ENDIF, - opPushData $ serialize (getPubKey clientPK), OP_CHECKSIG] - where encodeScriptInt i = opPushData $ B.pack $ HI.encodeInt (fromIntegral i) - -- Note: HI.encodeInt encodes values up to and including 2^31-1 as 4 bytes - -- and values 2^31 through 2^32-1 (upper limit) as 5 bytes. - --- |scriptSig fulfilling a payment channel redeemScript -paymentTxScriptSig :: PaymentSignature -> PaymentSignature -> Script --ScriptSig -paymentTxScriptSig clientSig serverSig = Script - [opPushData $ serialize clientSig, --sig including SigHash byte - opPushData $ serialize serverSig, --sig including SigHash byte - OP_1] - --- |scriptSig used for the valueSender refund transaction -refundTxScriptSig :: HC.Signature -> Script -refundTxScriptSig clientSig = Script - [opPushData (B.append (serialize clientSig) hashTypeByte), - OP_0] - where hashTypeByte = serialize (SigAll False) - ------Util----- - -op_CHECKLOCKTIMEVERIFY = OP_NOP2 - -scriptToP2SHAddress :: Script -> HC.Address -scriptToP2SHAddress = HC.ScriptAddress . HC.hash160 . HC.getHash256 . HC.hash256 . serialize - - -getP2SHFundingAddress :: ChannelParameters -> HC.Address -getP2SHFundingAddress = scriptToP2SHAddress . getRedeemScript - -getRedeemScript :: ChannelParameters -> Script --RedeemScript -getRedeemScript (CChannelParameters senderPK recvrPK lockTime) = - paymentChannelRedeemScript senderPK recvrPK (toWord32 lockTime) - -getRedeemScriptBS :: ChannelParameters -> B.ByteString -getRedeemScriptBS = serialize . getRedeemScript - -getInputScript :: ChannelParameters -> Script -> Script -getInputScript cp scriptSig = - Script $ scriptOps scriptSig ++ redeemScript - where - redeemScript = [opPushData $ getRedeemScriptBS cp] - 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 @@ -5,22 +5,17 @@ module Data.Bitcoin.PaymentChannel.Internal.Serialization where import Data.Bitcoin.PaymentChannel.Internal.Types -import Data.Bitcoin.PaymentChannel.Internal.Util - (deserEither, toHexString, - parseBitcoinLocktime, BitcoinLockTime(..), toWord32) - -import Data.Aeson (Value(Number), FromJSON(..), ToJSON(..), - withText, withScientific) +import Data.Bitcoin.PaymentChannel.Internal.Util (deserEither, toHexString) +import Data.Aeson (Value(Number), FromJSON(..), ToJSON(..), withText, withScientific) import Data.Aeson.Types (Parser) import Data.Scientific (Scientific, scientific, toBoundedInteger) import Data.Text.Encoding (decodeLatin1, encodeUtf8) -import Data.ByteString.Lazy (toStrict, fromStrict) -import qualified Data.Binary as Bin -import qualified Data.Binary.Put as BinPut -import qualified Data.Binary.Get as BinGet +import qualified Data.Serialize as Bin +import qualified Data.Serialize.Put as BinPut +import qualified Data.Serialize.Get as BinGet + import qualified Data.ByteString.Base64.URL as B64 import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import Data.Word (Word64) import Data.EitherR (fmapL) @@ -28,7 +23,7 @@ ----- JSON +--- JSON deriving instance ToJSON SendPubKey deriving instance FromJSON SendPubKey deriving instance ToJSON RecvPubKey @@ -64,44 +59,41 @@ --- Binary -deriving instance Bin.Binary SendPubKey -deriving instance Bin.Binary RecvPubKey +deriving instance Bin.Serialize SendPubKey +deriving instance Bin.Serialize RecvPubKey -instance Bin.Binary PaymentChannelState where - put (CPaymentChannelState par fti payConf valLeft (Just sig)) = +instance Bin.Serialize PaymentChannelState where + put (CPaymentChannelState par fti payConf valLeft sig) = Bin.put par >> Bin.put fti >> Bin.put payConf >> Bin.put valLeft - >> BinPut.putWord8 1 >> Bin.put sig - put (CPaymentChannelState par fti payConf valLeft Nothing) = - Bin.put par >> Bin.put fti >> Bin.put payConf >> Bin.put valLeft - >> BinPut.putWord8 0 + >> BinPut.putWord8 1 >> Bin.put sig -- Keep the 0x01 Word8 for format backwards compatibility get = CPaymentChannelState <$> Bin.get <*> Bin.get <*> Bin.get <*> Bin.get <*> (BinGet.getWord8 >>= \w -> case w of - 1 -> fmap Just Bin.get - _ -> return Nothing) + 1 -> Bin.get + _ -> error "empty PaymentChannelState no longer supported") -instance Bin.Binary ChannelParameters where - put (CChannelParameters pks pkr lt) = - Bin.put pks >> Bin.put pkr >> Bin.put lt - get = CChannelParameters <$> Bin.get <*> Bin.get <*> Bin.get +instance Bin.Serialize ChannelParameters where + put (CChannelParameters pks pkr lt dustLimit) = + Bin.put pks >> Bin.put pkr >> Bin.put lt >> Bin.put dustLimit + get = CChannelParameters <$> Bin.get <*> Bin.get <*> Bin.get <*> Bin.get -instance Bin.Binary FundingTxInfo where +instance Bin.Serialize FundingTxInfo where put (CFundingTxInfo h idx val) = Bin.put h >> BinPut.putWord32be idx >> Bin.put val get = CFundingTxInfo <$> Bin.get <*> BinGet.getWord32be <*> Bin.get -instance Bin.Binary PaymentTxConfig where +instance Bin.Serialize PaymentTxConfig where put (CPaymentTxConfig sendAddr) = Bin.put sendAddr get = CPaymentTxConfig <$> Bin.get -instance Bin.Binary Payment where +instance Bin.Serialize Payment where put (CPayment val sig) = Bin.put val >> Bin.put sig get = CPayment <$> Bin.get <*> Bin.get -instance Bin.Binary PaymentSignature where - put ps = Bin.put (psSig ps) - >> Bin.put (psSigHash ps) +instance Bin.Serialize PaymentSignature where + put ps = Bin.put (psSig ps) >> + Bin.put (psSigHash ps) get = CPaymentSignature <$> Bin.get <*> Bin.get @@ -109,30 +101,30 @@ instance Show Payment where show (CPayment val sig) = "" + ", sig=" ++ toHexString (Bin.encode sig) ++ ">" - -- Needed to convert from Scientific +-- Needed to convert from Scientific instance Bounded BitcoinAmount where minBound = BitcoinAmount 0 maxBound = BitcoinAmount $ round $ 21e6 * 1e8 --- Util -b64Encode :: Bin.Binary a => a -> B.ByteString -b64Encode = B64.encode . toStrict . Bin.encode +b64Encode :: Bin.Serialize a => a -> B.ByteString +b64Encode = B64.encode . Bin.encode -b64Decode :: (Typeable a, Bin.Binary a) => B.ByteString -> Either String a +b64Decode :: (Typeable a, Bin.Serialize a) => B.ByteString -> Either String a b64Decode b64 = - concatErr "failed to deserialize parsed base64 data: " . deserEither . BL.fromStrict =<< + concatErr "failed to deserialize parsed base64 data: " . deserEither =<< (concatErr "failed to parse base64 data: ") (b64Decode b64) where b64Decode = B64.decode . padToMod4 concatErr e = fmapL (e ++) -txtB64Encode :: Bin.Binary a => a -> T.Text +txtB64Encode :: Bin.Serialize a => a -> T.Text txtB64Encode = decodeLatin1 . b64Encode -txtB64Decode :: (Typeable a, Bin.Binary a) => T.Text -> Parser a +txtB64Decode :: (Typeable a, Bin.Serialize a) => T.Text -> Parser a txtB64Decode = either fail return . b64Decode . encodeUtf8 parseJSONInt :: Scientific -> Parser Integer @@ -152,5 +144,6 @@ let lastGroupSize = B.length bs `mod` 4 numPadChars = if lastGroupSize > 0 then 4 - lastGroupSize else 0 + equalASCIIChar = 61 in - B.concat [bs, B.replicate numPadChars 61] -- 61: '=' ASCII + B.concat [bs, B.replicate numPadChars equalASCIIChar] 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 @@ -2,56 +2,77 @@ import Data.Bitcoin.PaymentChannel.Internal.Types import Data.Bitcoin.PaymentChannel.Internal.Payment -import Data.Bitcoin.PaymentChannel.Internal.State -import Data.Bitcoin.PaymentChannel.Internal.Script +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.Error import qualified Network.Haskoin.Transaction as HT -import qualified Network.Haskoin.Internals as HI import qualified Network.Haskoin.Crypto as HC import qualified Network.Haskoin.Script as HS +-- |Sign everything, and do not allow additional inputs to be added afterwards. +serverSigHash = HS.SigAll False -getSettlementTxForSigning :: - PaymentChannelState - -> HC.Address - -> BitcoinAmount -- ^Bitcoin transaction fee for final payment transaction - -> (HT.Tx, HS.SigHash) -- ^ Transaction plus valueReceiver SigHash -getSettlementTxForSigning st@(CPaymentChannelState _ fti@(CFundingTxInfo _ _ channelTotalValue) - _ senderVal (Just (CPaymentSignature sig sigHash))) recvAddr txFee = - let - (baseTx,_) = getPaymentTxForSigning st senderVal - adjTx = if sigHash == HS.SigNone True then removeOutputs baseTx else baseTx - receiverAmount = channelTotalValue - senderVal - txFee -- may be less than zero - recvOut = HT.TxOut (fromIntegral . toInteger $ receiverAmount) (addressToScriptPubKeyBS recvAddr) - in - paymentTxAddOutput recvOut adjTx -getSettlementTxForSigning _ _ _ = error "no payment sig available" +csFromState :: PaymentChannelState -> ClientSignedPayment +csFromState cs@(CPaymentChannelState _ _ _ _ clientSig) = + ClientSignedPayment (fromState cs) clientSig +toUnsignedSettlementTx :: ClientSignedPayment -> HC.Address -> BitcoinAmount -> HT.Tx +toUnsignedSettlementTx + (ClientSignedPayment + unsignedPayment@(UnsignedPayment _ valueAvailable _ _ senderVal) + (CPaymentSignature _ sigHash) ) recvAddr txFee = + let + baseTx = toUnsignedBitcoinTx unsignedPayment + adjustedTx = if sigHash == HS.SigNone True then removeOutputs baseTx else baseTx + -- TODO: check dust? + receiverAmount = valueAvailable - senderVal - txFee + recvOut = HT.TxOut + (fromIntegral . toInteger $ receiverAmount) + (addressToScriptPubKeyBS recvAddr) + in + appendOutput adjustedTx recvOut + getSettlementTxHashForSigning :: + ClientSignedPayment + -> ChannelParameters + -> HC.Address -- ^Receiver destination address + -> 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 + -> HC.Address -- ^Receiver destination address -> BitcoinAmount -- ^Bitcoin transaction fee -> HC.Hash256 -getSettlementTxHashForSigning pcs@(CPaymentChannelState cp _ _ _ _) recvAddr txFee = - HS.txSigHash tx (getRedeemScript cp) 0 sigHash - where (tx,sigHash) = getSettlementTxForSigning pcs recvAddr txFee +settlementSigningTxHashFromState cs@(CPaymentChannelState cp _ _ _ _) = + getSettlementTxHashForSigning (csFromState cs) cp getSignedSettlementTx :: - PaymentChannelState - -> HC.Address -- ^Receiver/server change address + ClientSignedPayment + -> ChannelParameters + -> HC.Address -- ^Receiver/server funds destination address -> BitcoinAmount -- ^Bitcoin tx fee -> HC.Signature -- ^Signature over 'getSettlementTxHashForSigning' which verifies against serverPubKey - -> Maybe FinalTx -getSignedSettlementTx pcs@(CPaymentChannelState - cp@(CChannelParameters senderPK rcvrPK lt) _ _ _ (Just clientSig)) recvAddr txFee serverRawSig = + -> HT.Tx +getSignedSettlementTx csPayment@(ClientSignedPayment _ clientSig) + cp recvAddr txFee serverRawSig = let - (tx,recvSigHash) = getSettlementTxForSigning pcs recvAddr txFee - serverSig = CPaymentSignature serverRawSig recvSigHash - inputScript = getInputScript cp $ paymentTxScriptSig clientSig serverSig + unsignedTx = toUnsignedSettlementTx csPayment recvAddr txFee + serverSig = CPaymentSignature serverRawSig serverSigHash + inputScript = getP2SHInputScript cp $ paymentTxScriptSig clientSig serverSig in - Just $ replaceScriptInput (serialize inputScript) tx -getSignedSettlementTx (CPaymentChannelState _ _ _ _ Nothing) _ _ _ = Nothing - + replaceScriptInput 0 (serialize inputScript) unsignedTx +signedSettlementTxFromState :: + PaymentChannelState + -> (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 + -> HT.Tx +signedSettlementTxFromState cs@(CPaymentChannelState cp _ _ _ _) signFunc recvAddr txFee = + getSignedSettlementTx (csFromState cs) cp recvAddr txFee serverSig + where serverSig = signFunc (settlementSigningTxHashFromState cs recvAddr txFee) 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 @@ -15,6 +15,7 @@ pcsChannelValueLeft = pcsValueLeft pcsClientPubKey = cpSenderPubKey . pcsParameters pcsServerPubKey = cpReceiverPubKey . pcsParameters +pcsDustLimit = cpDustLimit . pcsParameters pcsExpirationDate = cpLockTime . pcsParameters pcsClientChangeAddress = ptcSenderChangeAddress . pcsPaymentConfig pcsClientChangeScriptPubKey = addressToScriptPubKeyBS . pcsClientChangeAddress @@ -24,8 +25,8 @@ pcsChannelID pcs = HT.OutPoint (ftiHash fti) (ftiOutIndex fti) where fti = pcsFundingTxInfo pcs -pcsGetPayment :: PaymentChannelState -> Maybe Payment -pcsGetPayment (CPaymentChannelState _ _ _ val maybeSig) = CPayment val <$> maybeSig +pcsGetPayment :: PaymentChannelState -> Payment +pcsGetPayment (CPaymentChannelState _ _ _ val sig) = CPayment val sig -- |Set new client/sender change address. -- Use this function if the client wishes to change its change address. @@ -36,43 +37,42 @@ pcs { pcsPaymentConfig = newPayConf } where newPayConf = pConf { ptcSenderChangeAddress = addr } --- | +-- |We subtract the specified "dust" limit from the total available value, +-- in order to avoid creating a Bitcoin transaction that won't circulate +-- in the Bitcoin P2P network. channelValueLeft :: PaymentChannelState -> BitcoinAmount -channelValueLeft pcs = - if channelIsExhausted pcs then 0 else pcsValueLeft pcs +channelValueLeft pcs@(CPaymentChannelState (CChannelParameters _ _ _ dustLimit) _ _ _ _) = + pcsValueLeft pcs - dustLimit -- |Returns 'True' if all available channel value has been transferred, 'False' otherwise channelIsExhausted :: PaymentChannelState -> Bool channelIsExhausted pcs = - case pcsPaymentSignature pcs of - Nothing -> False - -- Channel can be auto-closed when sender has given up all value - -- which requires a SigNone signature - Just paySig -> psSigHash paySig == HS.SigNone True + psSigHash (pcsPaymentSignature pcs) == HS.SigNone True || + channelValueLeft pcs == 0 -newPaymentChannelState channelParameters fundingTxInfo paymentConfig = +newPaymentChannelState channelParameters fundingTxInfo paymentConfig paySig = CPaymentChannelState { pcsParameters = channelParameters, pcsFundingTxInfo = fundingTxInfo, pcsPaymentConfig = paymentConfig, pcsValueLeft = ftiOutValue fundingTxInfo, - pcsPaymentSignature = Nothing + pcsPaymentSignature = paySig } --- |Update state with verified payment +-- |Update state with verified payment. Check value (including dust limit). updatePaymentChannelState :: PaymentChannelState -> Payment -> Either PayChanError PaymentChannelState -updatePaymentChannelState pcs@(CPaymentChannelState par fun pconf oldSenderVal oldSig) - payment@(CPayment newSenderVal newSig) +updatePaymentChannelState (CPaymentChannelState cp fun pconf oldSenderVal _) + payment@(CPayment newSenderVal _) | newSenderVal <= oldSenderVal = - fmap (Just . cpSignature) (checkDustLimit payment) >>= - return . (CPaymentChannelState par fun pconf newSenderVal) -- (Just newSig) + CPaymentChannelState cp fun pconf newSenderVal . cpSignature <$> + checkDustLimit cp payment | otherwise = Left $ BadPaymentValue (newSenderVal - oldSenderVal) -checkDustLimit :: Payment -> Either PayChanError Payment -checkDustLimit payment@(CPayment senderChangeVal sig) - | senderChangeVal < dUST_LIMIT = - if psSigHash sig /= HS.SigNone True then Left DustOutput else Right payment +checkDustLimit :: ChannelParameters -> Payment -> Either PayChanError Payment +checkDustLimit (CChannelParameters _ _ _ dustLimit) payment@(CPayment senderChangeVal _) + | senderChangeVal < dustLimit = + Left DustOutput | otherwise = Right payment 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 @@ -3,14 +3,15 @@ module Data.Bitcoin.PaymentChannel.Internal.Types ( module Data.Bitcoin.PaymentChannel.Internal.Types - , module Data.Bitcoin.PaymentChannel.Internal.BitcoinAmount + , module Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Amount + , module Data.Bitcoin.PaymentChannel.Internal.Bitcoin.LockTime ) where import Data.Bitcoin.PaymentChannel.Internal.Util -import Data.Bitcoin.PaymentChannel.Internal.Version -import Data.Bitcoin.PaymentChannel.Internal.BitcoinAmount +import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Amount +import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.LockTime import qualified Network.Haskoin.Transaction as HT import qualified Network.Haskoin.Crypto as HC @@ -19,9 +20,8 @@ import Data.Word -dUST_LIMIT = 700 :: BitcoinAmount -mIN_CHANNEL_SIZE = 1400 :: BitcoinAmount -pROTOCOL_VERSION = CVersion 2 0 +defaultDustLimit = 700 :: BitcoinAmount +defaultMinChanSize = defaultDustLimit * 2 newtype UnsignedPaymentTx = CUnsignedPaymentTx { unsignedTx :: HT.Tx } deriving Show type FinalTx = HT.Tx @@ -32,13 +32,11 @@ pcsParameters :: ChannelParameters, -- |Retrieved by looking at the in-blockchain funding transaction pcsFundingTxInfo :: FundingTxInfo, - pcsPaymentConfig :: PaymentTxConfig, - -- |Value left to send (starts at @ftiOutValue . pcsFundingTxInfo@) + -- |Value left to send (starts at @`-` dustLimit . ftiOutValue . pcsFundingTxInfo@) pcsValueLeft :: BitcoinAmount, -- |Signature over payment transaction of value 'pcsValueLeft' - -- unless no payment has been registered yet - pcsPaymentSignature :: Maybe PaymentSignature + pcsPaymentSignature :: PaymentSignature } deriving (Eq, Show, Typeable) -- |Defines channel: sender, receiver, and expiration date @@ -46,7 +44,13 @@ cpSenderPubKey :: SendPubKey, cpReceiverPubKey :: RecvPubKey, -- |Channel expiration date/time - cpLockTime :: BitcoinLockTime + cpLockTime :: BitcoinLockTime, + -- |Use a per-channel dust limit, such that when the remaining channel value + -- hits this limit (rather than zero), we say the channel is exhausted. + -- This avoids the relatively complex SigSingle/SigNone logic, and reduces + -- a payment to just a ANYONECANPAY|SigSingle signature with a corresponding + -- change output, which is set to the channel funding address. + cpDustLimit :: BitcoinAmount } deriving (Eq, Show, Typeable) -- |Holds information about the Bitcoin transaction used to fund 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 @@ -1,37 +1,33 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} -module Data.Bitcoin.PaymentChannel.Internal.Util where +module Data.Bitcoin.PaymentChannel.Internal.Util +( + module Data.Bitcoin.PaymentChannel.Internal.Util +, module Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Util +, module Data.Bitcoin.PaymentChannel.Internal.Bitcoin.LockTime +) + where +import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Util +import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.LockTime + import Data.String (fromString) -import qualified Data.Serialize as Ser -import qualified Data.Serialize.Put as SerPut -import qualified Data.Serialize.Get as SerGet -import qualified Data.Binary as Bin -import qualified Data.Binary.Put as BinPut -import qualified Data.Binary.Get as BinGet -import Data.Binary.Put (putWord32le) -import Data.Binary.Get (getWord32le) -import Data.Word -import Data.Time.Clock -import Data.Time.Clock.POSIX -import qualified Data.ByteString.Base16 as B16 + +import qualified Data.Serialize as Bin +import qualified Data.Serialize.Get as BinGet + +import Data.Typeable +import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Char8 as C -import qualified Network.Haskoin.Transaction as HT -import qualified Network.Haskoin.Script as HS import qualified Network.Haskoin.Crypto as HC -import Data.Typeable --- import Data.Text.p + mapLeft f = either (Left . f) Right mapRight f = either Left (Right . f) dummyHash256 = fromString "3d96c573baf8f782e5f5f33dc8ce3c5bae654cbc888e9a3bbb8185a75febfd76" :: HC.Hash256 -testHey = toHexString $ serialize $ HT.TxHash dummyHash256 - toHexString :: B.ByteString -> String toHexString = C.unpack . B16.encode @@ -44,107 +40,25 @@ (bs,e) -> if B.length e /= 0 then B.empty else bs --- | Converts a pay-to-pubkey-hash address string to Script. --- | Eg. \"1PDGytNA7EJ5XrJdTGKv11VAUFxKnsfwke\" into --- | \"Script [OP_DUP, OP_HASH160, OP_PUSHDATA f3a5194fbf4b3556838e0f773b613a876737a2c6, --- | OP_EQUALVERIFY, OP_CHECKSIG]\" -p2PKAddressToScript :: String -> Maybe HS.Script -p2PKAddressToScript addrStr = - HS.encodeOutput . HS.PayPKHash <$> HC.base58ToAddr (C.pack addrStr) - --- | Converts a pay-to-script-hash address string to Script. --- | Eg. \"2PDGytNA7EJ5XrJdTGKv11VAUFxKnsfwke\" -p2SHAddressToScript :: String -> Maybe HS.Script -p2SHAddressToScript addrStr = - HS.encodeOutput . HS.PayScriptHash <$> HC.base58ToAddr (C.pack addrStr) - -addressToScript :: HC.Address -> HS.ScriptOutput -addressToScript addr = - case addr of - a@(HC.PubKeyAddress _) -> HS.PayPKHash a - a@(HC.ScriptAddress _) -> HS.PayScriptHash a - -addressToScriptPubKeyBS :: HC.Address -> B.ByteString -addressToScriptPubKeyBS = HS.encodeOutputBS . addressToScript - -serialize' :: Ser.Serialize a => a -> B.ByteString -serialize' = Ser.encode - -serialize :: Bin.Binary a => a -> B.ByteString -serialize = BL.toStrict . Bin.encode - -deserialize :: Bin.Binary a => B.ByteString -> a -deserialize = Bin.decode . BL.fromStrict +serialize :: Bin.Serialize a => a -> B.ByteString +serialize = Bin.encode -deserEither :: forall m a. (Typeable a, Bin.Binary a) => BL.ByteString -> Either String a +deserEither :: forall a. (Typeable a, Bin.Serialize a) => B.ByteString -> Either String a deserEither bs = do - let eitherRes = Bin.decodeOrFail bs - case eitherRes of - Left (leftoverBS,offset,e) -> Left $ - "Type: " ++ show (typeOf (undefined :: a)) ++ - ". Error: " ++ e ++ - ". Data consumed (" ++ show offset ++ " bytes): " ++ - toHexString (BL.toStrict $ BL.take offset bs) ++ - ". Unconsumed data: (" ++ show ( BL.length bs - fromIntegral offset ) ++ " bytes): " ++ - toHexString (BL.toStrict leftoverBS) - Right (_,_,val) -> Right val - - -----------BITCOIN----------- - -replaceScriptInput :: B.ByteString -> HT.Tx -> HT.Tx -replaceScriptInput scriptIn (HT.Tx v (txIn:_) txOut lt) = - HT.Tx v [newTxIn] txOut lt - where newTxIn = txIn { HT.scriptInput = scriptIn } -replaceScriptInput _ (HT.Tx _ [] _ _) = - error "cannot replace scriptInput without any inputs" - -removeOutputs :: HT.Tx -> HT.Tx -removeOutputs tx = tx { HT.txOut = [] } - -appendOutput :: HT.Tx -> HT.TxOut -> HT.Tx -appendOutput tx@HT.Tx{ HT.txOut = oldOuts } txOut = - tx { HT.txOut = oldOuts ++ [txOut] } - --- |Data type representing a Bitcoin LockTime, which specifies a point in time. --- Derive a 'BitcoinLockTime' from a 'Data.Time.Clock.UTCTime' using 'fromDate'. -data BitcoinLockTime = - -- |A value of "n" represents the point in time at which Bitcoin block number "n" appears - LockTimeBlockHeight Word32 | - -- |Specifies a point in time using a timestamp with 1-second accuraccy - LockTimeDate UTCTime deriving (Eq, Ord, Typeable) - -instance Show BitcoinLockTime where - show (LockTimeBlockHeight blockNum) = "block number " ++ show blockNum - show (LockTimeDate date) = show date - --- | Convert from Bitcoin format ('Word32') -parseBitcoinLocktime :: Word32 -> BitcoinLockTime -parseBitcoinLocktime i - | i < 500000000 = LockTimeBlockHeight i - | i >= 500000000 = LockTimeDate $ posixSecondsToUTCTime (fromIntegral i) - | otherwise = error "GHC bug?" - --- | Convert to Bitcoin format ('Word32') -toWord32 :: BitcoinLockTime -> Word32 -toWord32 (LockTimeBlockHeight i) = i -toWord32 (LockTimeDate date) = - fromIntegral . round . utcTimeToPOSIXSeconds $ date - --- | Convert a 'Data.Time.Clock.UTCTime' to a 'BitcoinLockTime' -fromDate :: UTCTime -> BitcoinLockTime -fromDate = LockTimeDate - -usesBlockHeight :: BitcoinLockTime -> Bool -usesBlockHeight (LockTimeBlockHeight _) = True -usesBlockHeight _ = False - - -instance Bin.Binary BitcoinLockTime where - put = putWord32le . toWord32 - get = parseBitcoinLocktime <$> getWord32le + let eitherRes' = BinGet.runGetPartial (Bin.get :: BinGet.Get a) bs + handleResult eitherRes' + where + handleResult eitherRes = case eitherRes of + BinGet.Done val _ -> Right val + BinGet.Partial feedFunc -> handleResult $ feedFunc B.empty + BinGet.Fail e leftoverBS -> Left $ + "Type: " ++ show (typeOf (undefined :: a)) ++ + ". Error: " ++ e ++ + ". Data consumed (" ++ show offset ++ " bytes): " ++ + toHexString (B.take offset bs) ++ + ". Unconsumed data: (" ++ show ( B.length bs - fromIntegral offset ) ++ + " bytes): " ++ + toHexString leftoverBS + where offset = B.length bs - B.length leftoverBS -bitcoinPayPK :: HC.PubKey -> HS.Script -bitcoinPayPK pk = HS.encodeOutput $ HS.PayPKHash $ HC.pubKeyAddr pk -bitcoinPayPKBS = serialize . bitcoinPayPK diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Version.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Version.hs deleted file mode 100644 --- a/src/Data/Bitcoin/PaymentChannel/Internal/Version.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Data.Bitcoin.PaymentChannel.Internal.Version where - -import Data.Int - -data Version = CVersion { - versionMajor :: Int32, - versionMinor :: Int32 -} deriving Show 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 @@ -28,8 +28,7 @@ -- Util b64Encode, -- Constants -dUST_LIMIT, -mIN_CHANNEL_SIZE +defaultDustLimit, ) where @@ -37,21 +36,20 @@ (BitcoinAmount(..), PaymentChannelState(..), Payment(..) ,FundingTxInfo(..), ChannelParameters(..), - PaymentSignature(..), SendPubKey(..), RecvPubKey(..), IsPubKey(..), - dUST_LIMIT, mIN_CHANNEL_SIZE) + SendPubKey(..), RecvPubKey(..), IsPubKey(..), + defaultDustLimit, + BitcoinLockTime(..), fromDate, usesBlockHeight) import Data.Bitcoin.PaymentChannel.Internal.Serialization --- () -import Data.Bitcoin.PaymentChannel.Internal.Util - (BitcoinLockTime(..), fromDate, usesBlockHeight) + import qualified Data.Bitcoin.PaymentChannel.Internal.State as S import Data.Bitcoin.PaymentChannel.Internal.Error (PayChanError(..)) --- import Data.Bitcoin.PaymentChannel.Internal.Types () -import qualified Data.Binary as Bin + +import qualified Data.Serialize as Bin import Data.Aeson as JSON -- (FromJSON, ToJSON) import qualified Network.Haskoin.Crypto as HC import qualified Network.Haskoin.Transaction as HT -import qualified Network.Haskoin.Script as HS + -- |Get various information about an open payment channel. class PaymentChannel a where -- |Get value sent to receiver/left for sender @@ -72,23 +70,15 @@ getChannelID = S.pcsChannelID . getChannelState getExpirationDate = S.pcsExpirationDate . getChannelState - channelValueLeft = S.channelValueLeft . getChannelState channelIsExhausted = S.channelIsExhausted . getChannelState expiresBefore expDate chan = getExpirationDate chan < expDate - - - getNewestPayment pcs = case S.pcsGetPayment (getChannelState pcs) of - Just payment -> payment - Nothing -> error "BUG: PaymentChannel interface shouldn't allow payment-less PaymentChannel" + getNewestPayment pcs = S.pcsGetPayment (getChannelState pcs) -- |State object for the value sender data SenderPaymentChannel = CSenderPaymentChannel { -- |Internal state object spcState :: PaymentChannelState, - -- |Used to sign payments from sender. - -- This function, when given a 'HC.Hash256', produces a signature that - -- verifies against 'cpSenderPubKey'. spcSignFunc :: HC.Hash256 -> HC.Signature } @@ -96,7 +86,7 @@ newtype ReceiverPaymentChannel = CReceiverPaymentChannel { -- |Internal state object rpcState :: PaymentChannelState -} deriving (Eq, Bin.Binary, FromJSON, ToJSON) +} deriving (Eq, Bin.Serialize, FromJSON, ToJSON) instance PaymentChannel SenderPaymentChannel where valueToMe = channelValueLeft 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 @@ -13,8 +13,8 @@ getFundingAddress, setSenderChangeAddress, -serialize, serialize', -BitcoinLockTime, parseBitcoinLocktime, toWord32, fromDate, deserEither, +serialize, deserEither, +BitcoinLockTime, parseBitcoinLocktime, toWord32, fromDate, parseJSONInt, unsafeUpdateRecvState @@ -22,15 +22,14 @@ where import Data.Bitcoin.PaymentChannel.Internal.Types - (PaymentChannelState(..), PaymentTxConfig(..), + (PaymentChannelState(..), Payment(..)) -- import Data.Bitcoin.PaymentChannel.Internal.State -- (ptcSenderChangeAddress) -import Data.Bitcoin.PaymentChannel.Internal.Script +import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Script (getP2SHFundingAddress) import Data.Bitcoin.PaymentChannel.Internal.Util - (BitcoinLockTime, parseBitcoinLocktime, toWord32, fromDate, deserEither, - serialize, serialize') + (parseBitcoinLocktime, toWord32, deserEither, serialize) import Data.Bitcoin.PaymentChannel.Internal.State (setClientChangeAddress) import Data.Bitcoin.PaymentChannel.Internal.Serialization @@ -46,6 +45,7 @@ -- The transaction which pays to this address is the channel funding transaction, -- and information about this transaction is contained in -- 'FundingTxInfo'. +getFundingAddress :: ChannelParameters -> HC.Address getFundingAddress = getP2SHFundingAddress -- |Set new value sender change address @@ -58,5 +58,6 @@ -- verified the signature, and it just needs to be stored. unsafeUpdateRecvState :: ReceiverPaymentChannel -> Payment -> ReceiverPaymentChannel unsafeUpdateRecvState (CReceiverPaymentChannel s) (CPayment val sig) = - CReceiverPaymentChannel $ s { pcsValueLeft = val, pcsPaymentSignature = Just sig} + CReceiverPaymentChannel $ s { pcsValueLeft = val, pcsPaymentSignature = sig} + diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,35 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + module Main where import Data.Bitcoin.PaymentChannel import Data.Bitcoin.PaymentChannel.Types import Data.Bitcoin.PaymentChannel.Util --- import Data.Bitcoin.PaymentChannel.Internal.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 Network.Haskoin.Test.Crypto -import Network.Haskoin.Test -- (ArbitraryHash256, ArbitraryTxHash(..)) -import Network.Haskoin.Constants -import Data.Maybe -import Control.Monad +import Network.Haskoin.Test -import Test.QuickCheck -- (elements, Gen, arbitrary, Property, quickCheck, (==>)) -import Test.QuickCheck.Monadic -- (assert, monadicIO, pick, pre, run) -import Debug.Trace +import Test.QuickCheck -data ArbChannelPair = ArbChannelPair SenderPaymentChannel ReceiverPaymentChannel - deriving (Show) +dUST_LIMIT = 700 :: BitcoinAmount +mIN_CHANNEL_SIZE = 1400 :: BitcoinAmount +testAddrTestnet = "2N414xMNQaiaHCT5D7JamPz7hJEc9RG7469" :: HC.Address +testAddrLivenet = "14wjVnwHwMAXDr6h5Fw38shCWUB6RSEa63" :: HC.Address + + +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) amount = +doPayment (ArbChannelPair spc rpc sendList recvList f) amount = let - (pmn, newSpc) = sendPayment spc amount + (amountSent, pmn, newSpc) = sendPayment spc amount eitherRpc = recvPayment rpc pmn in case eitherRpc of Left e -> error (show e) - Right (rAmt, newRpc) -> ArbChannelPair newSpc newRpc + Right (recvAmount, newRpc) -> + ArbChannelPair newSpc newRpc + (amountSent : sendList) + (recvAmount : recvList) + f instance Arbitrary ArbChannelPair where arbitrary = mkChanPair @@ -42,23 +54,22 @@ ArbitraryPubKey recvPriv recvPK <- arbitrary -- expiration date lockTime <- arbitrary - let cp = CChannelParameters (MkSendPubKey sendPK) (MkRecvPubKey recvPK) lockTime - fti <- arbitrary - - -- total channel value - let chanAmount = fromIntegral $ ftiOutValue fti :: Integer + let cp = CChannelParameters + (MkSendPubKey sendPK) (MkRecvPubKey recvPK) lockTime dUST_LIMIT -- value of first payment initPayAmount <- arbitrary -- fromIntegral <$> choose (0, chanAmount) - let (paymnt,sendChan) = channelWithInitialPaymentOf + let (initPayActualAmount,paymnt,sendChan) = channelWithInitialPaymentOf cp fti (flip HC.signMsg sendPriv) (HC.pubKeyAddr sendPK) initPayAmount let eitherRecvChan = channelFromInitialPayment cp fti (HC.pubKeyAddr sendPK) paymnt case eitherRecvChan of - Left e -> error (show e) --return $ Left (show e) - Right (val,recvChan) -> return $ ArbChannelPair sendChan recvChan + Left e -> error (show e) + Right (initRecvAmount,recvChan) -> return $ ArbChannelPair + sendChan recvChan [initPayActualAmount] [initRecvAmount] + (flip HC.signMsg recvPriv) instance Arbitrary BitcoinLockTime where arbitrary = fmap parseBitcoinLocktime arbitrary @@ -73,23 +84,41 @@ return $ CFundingTxInfo h i amt instance Arbitrary BitcoinAmount where - arbitrary = fmap fromIntegral (choose (0,round $ 21e6 * 1e8 :: Integer)) + arbitrary = fromIntegral <$> choose (0, round $ 21e6 * 1e8 :: Integer) -runChanPair :: ArbChannelPair -> [BitcoinAmount] -> ArbChannelPair -runChanPair chanPair l = foldl doPayment chanPair l +runChanPair :: ArbChannelPair -> [BitcoinAmount] -> (ArbChannelPair, [BitcoinAmount]) +runChanPair chanPair paymentAmountList = + (foldl doPayment chanPair paymentAmountList, paymentAmountList) -checkChanPair :: ArbChannelPair -> Bool -checkChanPair (ArbChannelPair sendChan recvChan) = - getChannelState recvChan == getChannelState sendChan +checkChanPair :: (ArbChannelPair, [BitcoinAmount]) -> Bool +checkChanPair (ArbChannelPair sendChan recvChan amountSent amountRecvd 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) + let clientValueIsGood = fromIntegral clientChangeAmount == fundAmountMinusPaySum :: Bool + -- Debug print + let checkGoodClientValue goodCV = if not goodCV then + error $ "Bad client change value. Actual: " ++ show clientChangeAmount ++ + " should be " ++ show fundAmountMinusPaySum + else + goodCV + -- Check that sender/receiver (client/server) agree on channel state + let statesMatch = getChannelState recvChan == getChannelState sendChan + -- Send/recv value lists match + let recvSendAmountMatch = amountSent == amountRecvd + checkGoodClientValue clientValueIsGood && statesMatch && recvSendAmountMatch + testChanPair :: ArbChannelPair -> [BitcoinAmount] -> Bool -testChanPair p al = checkChanPair (runChanPair p al) +testChanPair arbChanPair paymentAmountList = + checkChanPair (runChanPair arbChanPair paymentAmountList) main :: IO () -main = do - quickCheckWith stdArgs -- { maxSuccess = 25 } - testChanPair --- (verbose $ testChanPair) +main = quickCheckWith stdArgs testChanPair +