bitcoin-payment-channel 0.2.3.1 → 0.3.0.0
raw patch · 20 files changed
+651/−597 lines, 20 filesdep ~base58stringdep ~haskoin-core
Dependency ranges changed: base58string, haskoin-core
Files
- bitcoin-payment-channel.cabal +12/−17
- src/Data/Bitcoin/PaymentChannel.hs +51/−56
- src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Amount.hs +58/−0
- src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/LockTime.hs +48/−0
- src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Script.hs +76/−0
- src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Util.hs +58/−0
- src/Data/Bitcoin/PaymentChannel/Internal/BitcoinAmount.hs +0/−61
- src/Data/Bitcoin/PaymentChannel/Internal/Error.hs +3/−6
- src/Data/Bitcoin/PaymentChannel/Internal/Payment.hs +93/−66
- src/Data/Bitcoin/PaymentChannel/Internal/Refund.hs +12/−11
- src/Data/Bitcoin/PaymentChannel/Internal/Script.hs +0/−84
- src/Data/Bitcoin/PaymentChannel/Internal/Serialization.hs +34/−41
- src/Data/Bitcoin/PaymentChannel/Internal/Settlement.hs +55/−34
- src/Data/Bitcoin/PaymentChannel/Internal/State.hs +21/−21
- src/Data/Bitcoin/PaymentChannel/Internal/Types.hs +15/−11
- src/Data/Bitcoin/PaymentChannel/Internal/Util.hs +35/−121
- src/Data/Bitcoin/PaymentChannel/Internal/Version.hs +0/−8
- src/Data/Bitcoin/PaymentChannel/Types.hs +10/−20
- src/Data/Bitcoin/PaymentChannel/Util.hs +8/−7
- test/Main.hs +62/−33
bitcoin-payment-channel.cabal view
@@ -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,
src/Data/Bitcoin/PaymentChannel.hs view
@@ -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
+ src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Amount.hs view
@@ -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
+ src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/LockTime.hs view
@@ -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+
+ src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Script.hs view
@@ -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]+
+ src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Util.hs view
@@ -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
− src/Data/Bitcoin/PaymentChannel/Internal/BitcoinAmount.hs
@@ -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-
src/Data/Bitcoin/PaymentChannel/Internal/Error.hs view
@@ -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
src/Data/Bitcoin/PaymentChannel/Internal/Payment.hs view
@@ -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---
src/Data/Bitcoin/PaymentChannel/Internal/Refund.hs view
@@ -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
− src/Data/Bitcoin/PaymentChannel/Internal/Script.hs
@@ -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]-
src/Data/Bitcoin/PaymentChannel/Internal/Serialization.hs view
@@ -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) = "<Payment: valLeft=" ++ show val ++- ", sig=" ++ toHexString (toStrict $ Bin.encode 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]
src/Data/Bitcoin/PaymentChannel/Internal/Settlement.hs view
@@ -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)
src/Data/Bitcoin/PaymentChannel/Internal/State.hs view
@@ -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
src/Data/Bitcoin/PaymentChannel/Internal/Types.hs view
@@ -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
src/Data/Bitcoin/PaymentChannel/Internal/Util.hs view
@@ -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
− src/Data/Bitcoin/PaymentChannel/Internal/Version.hs
@@ -1,8 +0,0 @@-module Data.Bitcoin.PaymentChannel.Internal.Version where--import Data.Int--data Version = CVersion {- versionMajor :: Int32,- versionMinor :: Int32-} deriving Show
src/Data/Bitcoin/PaymentChannel/Types.hs view
@@ -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
src/Data/Bitcoin/PaymentChannel/Util.hs view
@@ -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}+
test/Main.hs view
@@ -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+