diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bitcoin-payment-channel.cabal b/bitcoin-payment-channel.cabal new file mode 100644 --- /dev/null +++ b/bitcoin-payment-channel.cabal @@ -0,0 +1,55 @@ +name: bitcoin-payment-channel +version: 0.1.0.0 +synopsis: Library for working with Bitcoin payment channels +description: + A Bitcoin payment channel allows two parties two send value to each other very rapidly. + The speed of the value transfer is limited primarily by network latency, and payments + cannot be double spent, as the receiver of funds is defined during channel setup. + The channel setup procedure is trustless, in that the funding party is able to retrieve the funds, + after a chosen expiration date, in case the receiving party goes missing. + + This library implements a type of payment channel (CHECKLOCKTIMEVERIFY-style) where channel setup + is safe from transaction ID malleability, and value transfer is uni-directional (one party + sends and the other party receives). + +author: Rune K. Svendsen +maintainer: Rune K. Svendsen +license: PublicDomain +stability: experimental +homepage: https://github.com/runeksvendsen/bitcoin-payment-channel +bug-reports: https://github.com/runeksvendsen/bitcoin-payment-channel/issues +category: Bitcoin, Finance, Network +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: git + location: git://github.com/runeksvendsen/bitcoin-payment-channel.git + +library + exposed-modules: Data.Bitcoin.PaymentChannel, + Data.Bitcoin.PaymentChannel.Types, + Data.Bitcoin.PaymentChannel.Util + + other-modules: + Data.Bitcoin.PaymentChannel.Internal.Error + Data.Bitcoin.PaymentChannel.Internal.Payment, + Data.Bitcoin.PaymentChannel.Internal.Refund, + Data.Bitcoin.PaymentChannel.Internal.Script, + Data.Bitcoin.PaymentChannel.Internal.Settlement, + Data.Bitcoin.PaymentChannel.Internal.State, + Data.Bitcoin.PaymentChannel.Internal.Types, + Data.Bitcoin.PaymentChannel.Internal.Util, + Data.Bitcoin.PaymentChannel.Internal.Version + + ghc-options: -fwarn-incomplete-patterns + + build-depends: base >= 4.7 && < 5, + bytestring, text, base16-bytestring, base58string, hexstring, + time, + cereal, binary, + haskoin-core + + hs-source-dirs: src + + default-language: Haskell2010 diff --git a/src/Data/Bitcoin/PaymentChannel.hs b/src/Data/Bitcoin/PaymentChannel.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitcoin/PaymentChannel.hs @@ -0,0 +1,214 @@ +{-| +Module : Data.Bitcoin.PaymentChannel +Description : Bitcoin payment channel library +Copyright : (c) Rune K. Svendsen, 2016 +License : PublicDomain +Maintainer : runesvend@gmail.com +Stability : experimental +Portability : POSIX + +In order to set up a payment channel between a sender and a receiver, the two parties must + first agree on three parameters for the channel: + + (1) sender public key + (2) receiver public key + (3) channel expiration date + + These parameters + are contained in 'ChannelParameters', from which a channel funding + address can be derived using + 'getFundingAddress'. The transaction which pays to this address is the channel funding + transaction, and information about it is contained in a 'FundingTxInfo'. + So, the channel funding transaction will contain an output which pays to the address returned by + 'getFundingAddress', and once this transaction is created and in + the blockchain, a 'SenderPaymentChannel' and + 'ReceiverPaymentChannel' instance can be created, after first creating the 'FundingTxInfo' instance. + 'FundingTxInfo' contains three pieces of information about the funding transaction: + + (1) hash/transaction ID + (2) index/vout of the funding output (paying to 'getFundingAddress' address), + (3) value of the funding output (paying to 'getFundingAddress' address) + +With 'ChannelParameters' and 'FundingTxInfo', + the sender can create a new 'SenderPaymentChannel', plus + the first channel payment, using 'channelWithInitialPaymentOf'. 'channelWithInitialPaymentOf' + takes two additional arguments: + + (1) a signing function which, given a hash, produces a signature that verifies against + 'cpSenderPubKey' in 'ChannelParameters' + (2) the value of the first channel payment + + The sender will want to use @flip 'Network.Haskoin.Crypto.signMsg' senderPrivKey@ as the signing + function, where @senderPrivKey@ is the private key from which 'cpSenderPubKey' is derived. + 'channelWithInitialPaymentOf' will return the first channel 'Payment' as well as + the new 'SenderPaymentChannel' state. The new state is stored, and the 'Payment' + transferred to the receiver. + +The receiver will now create its own channel state object, 'ReceiverPaymentChannel', using + 'channelFromInitialPayment'. + 'channelFromInitialPayment' takes the same 'ChannelParameters' and 'FundingTxInfo' + as was provided by the sender, and, in addition, the receiver signing function + (used to produce the settlement transaction + that closes the payment channel), and the first channel 'Payment', received from the sender. + The receiver will want to use @flip 'Network.Haskoin.Crypto.signMsg' receiverPrivKey@ as the signing function, + where @@ is the private key from which 'cpReceiverPubKey' is derived. + +Now the payment channel is open and ready for transmitting value. A new 'Payment' is created by + the sender with 'sendPayment', which yields a new payment, that increases the total value transmitted + to the receiver by the specified amount, and an updated 'Data.Bitcoin.PaymentChannel.Types.SenderPaymentChannel' state. + The receiver will verify and register this 'Payment' on its side using 'recvPayment', which, on success, + returns the value received with this payment plus the updated + 'ReceiverPaymentChannel' state object. + +Payments can flow from the sender to receiver until either the channel is exhausted, or getting + close to expiration (see important note below). In either case the receiver will use 'getSettlementBitcoinTx' to create the settlement + Bitcoin transaction, and publish this transaction to the Bitcoin network. The settlement Bitcoin + transaction pays the total value transmitted over the channel to the receiver and the rest back + to the sender. + +__/IMPORTANT:/__ /Channel setup is risk free because the sender can derive a refund Bitcoin transaction/ + /using 'getRefundBitcoinTx', which returns the bitcoins used to fund the channel back to the sender./ + /This refund transaction, however, is not valid until the expiration date specified in 'ChannelParameters',/ + /but it is paramount that the value receiver gets a settlement transaction included in a block/ + /before the refund transaction becomes valid. Due to the fact that Bitcoin network time is allowed/ + /to drift up to two hours from actual time, and the fact that finding new Bitcoin blocks does not occur/ + /according to any schedule, it would be wise for the receiver to publish a settlement transaction at least/ + /4 hours before the specified channel expiration time, and possibly earlier, if the receiver wants to/ + /be cautious./ + +-} + +module Data.Bitcoin.PaymentChannel +( + channelWithInitialPaymentOf, + sendPayment, + + channelFromInitialPayment, + recvPayment, + + getSettlementBitcoinTx, + getRefundBitcoinTx, + + getFundingAddress +) +where + +import Data.Bitcoin.PaymentChannel.Internal.Error + (PayChanError(..)) +import Data.Bitcoin.PaymentChannel.Internal.Types + (PaymentTxConfig(..), pcsValueLeft, cpChannelValueLeft) +import Data.Bitcoin.PaymentChannel.Internal.State + (newPaymentChannelState, updatePaymentChannelState) +import Data.Bitcoin.PaymentChannel.Internal.Payment + (createPayment, verifyPayment) +import Data.Bitcoin.PaymentChannel.Internal.Settlement + (getSignedSettlementTx, getSettlementTxHashForSigning) +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 + + +-- |Create a new 'SenderPaymentChannel'. +-- A 'SenderPaymentChannel' object is created by supplying information about +-- 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' + -> 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 amount = + let pConf = CPaymentTxConfig (bitcoinPayPKBS sendPK) (bitcoinPayPKBS recvPK) in + sendPayment + (CSenderPaymentChannel (newPaymentChannelState cp fundInf pConf) signFunc) + amount + +-- |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 +sendPayment (CSenderPaymentChannel cs signFunc) amountToSend = + let + valSent = min (pcsValueLeft cs) amountToSend + newSenderValue = pcsValueLeft cs - valSent + payment = createPayment cs newSenderValue signFunc + in + case updatePaymentChannelState cs payment of + Right newCS -> + (payment + ,CSenderPaymentChannel newCS signFunc) + Left _ -> error "BUG #3: sendPayment should not be able to rewind payments" + +-- |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 +-- 'ChannelParameters'. Receiver beware of Bitcoin network time drift and the +-- unpreditable nature of finding new blocks. +getRefundBitcoinTx :: + SenderPaymentChannel -- ^Sender state object + -> BitcoinAmount -- ^Refund transaction fee + -> HT.Tx -- ^Refund Bitcoin transaction +getRefundBitcoinTx (CSenderPaymentChannel cs signFunc) txFee = + refundTxAddSignature cs txFee $ signFunc $ getRefundTxHashForSigning cs txFee + + +-- |Create new 'ReceiverPaymentChannel'. +-- A channel is initialized with various information +-- about the payment channel, as well as the first channel payment +-- produced by the sender. +channelFromInitialPayment :: + 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) -- ^ Function which produces a signature, over a hash, which verifies against 'cpReceiverPubKey' + -> Payment -- ^Initial channel payment + -> Either PayChanError ReceiverPaymentChannel -- ^Receiver state object +channelFromInitialPayment cp@(CChannelParameters sendPK recvPK _) + fundInf signFunc paymnt = + let + verifyFunc hash pk sig = HC.verifySig hash sig pk + pConf = CPaymentTxConfig (bitcoinPayPKBS sendPK) (bitcoinPayPKBS recvPK) + eitherNewState = flip recvPayment paymnt $ CReceiverPaymentChannel + (newPaymentChannelState cp fundInf pConf) verifyFunc signFunc + in + mapRight snd eitherNewState + +-- |Register, on the receiving side, a payment made by 'sendPayment' on the sending side. +-- Returns error if either the signature or payment amount is invalid, and otherwise +-- the amount received with this 'Payment' and a new state object. +recvPayment :: + ReceiverPaymentChannel -- ^Receiver state object + -> Payment -- ^Payment to verify and register + -> Either PayChanError (BitcoinAmount, ReceiverPaymentChannel) -- ^Value received plus new receiver state object +recvPayment rpc@(CReceiverPaymentChannel cs verifyFunc _) paymnt = + if verifyPayment cs paymnt verifyFunc then + updatePaymentChannelState cs paymnt >>= + (\newState -> Right (pcsValueLeft cs - cpChannelValueLeft paymnt, rpc { rpcState = newState })) + else + Left BadSignature + + +-- |The value transmitted over the channel is settled when this transaction is in the Blockchain. +-- The receiver will want to make sure a transaction produced by this function +-- 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 + -> BitcoinAmount -- ^Bitcoin transaction fee + -> Either PayChanError HT.Tx -- ^Settling Bitcoin transaction +getSettlementBitcoinTx (CReceiverPaymentChannel cs verifyFunc signFunc) txFee = + getSignedSettlementTx cs txFee serverSig + where serverSig = signFunc (getSettlementTxHashForSigning cs txFee) + + diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Error.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Error.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Error.hs @@ -0,0 +1,13 @@ +module Data.Bitcoin.PaymentChannel.Internal.Error where + +data PayChanError = + BadSignature | + BadPayment | + NoValueTransferred + +instance Show PayChanError where + show BadSignature = "signature failed verification" + show BadPayment = "payment amount to receiver less than previous payment" + show NoValueTransferred = "cannot create payment Bitcoin transaction: no\ + \ value has been transferred yet" + diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Payment.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Payment.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Payment.hs @@ -0,0 +1,93 @@ + +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.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 + + +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] + [] + 0 + +paymentTxAddOutput :: HT.TxOut -> HT.Tx -> (HT.Tx, HS.SigHash) +paymentTxAddOutput addOut tx@(HT.Tx _ _ outs _) + | HT.outValue addOut >= dUST_LIMIT = + (tx { HT.txOut = outs ++ [addOut] }, HS.SigSingle True) + | otherwise = + (tx, HS.SigNone True) + +getPaymentTxForSigning :: + PaymentChannelState + -> BitcoinAmount -- ^New sender value (newValueLeft) + -> (HT.Tx, HS.SigHash) +getPaymentTxForSigning st@(CPaymentChannelState _ fti + (CPaymentTxConfig sendChg _) chanValLeft _) newValueLeft = + paymentTxAddOutput senderOut $ buildEmptyPaymentTx fti + where senderOut = HT.TxOut (toWord64 newValueLeft) sendChg + +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@(CChannelParameters senderPK rcvrPK lt) _ _ _ _) newValueLeft = + (HS.txSigHash tx (getRedeemScript cp) 0 sigHash, sigHash) + where (tx,sigHash) = getPaymentTxForSigning st newValueLeft + +verifyPayment :: + PaymentChannelState + -> Payment + -> (HC.Hash256 -> HC.PubKey -> HC.Signature -> Bool) + -> Bool +verifyPayment pcs + (CPayment newSenderVal (CPaymentSignature sig sigHash)) verifyFunc = + let (hash,_) = case sigHash of --SigHash in signature overrides newSenderVal + HS.SigSingle True -> getPaymentTxHashForSigning pcs newSenderVal + --sender has relinquished remaining channel value + HS.SigNone True -> getPaymentTxHashForSigning pcs 0 + unknownSigHash -> (dummyHash256,sigHash) --will fail verification + in + verifyFunc hash (pcsClientPubKey pcs) sig + +createPayment :: + PaymentChannelState + -> BitcoinAmount -- ^ newSenderVal + -> (HC.Hash256 -> HC.Signature) -- ^ signing function + -> 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 + HS.SigAll _ -> error "BUG: unsupported SigHash" + HS.SigUnknown _ _ -> error "BUG: unsupported SigHash" + + + + + diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Refund.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Refund.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Refund.hs @@ -0,0 +1,39 @@ +module Data.Bitcoin.PaymentChannel.Internal.Refund where + +import Data.Bitcoin.PaymentChannel.Internal.Types +import Data.Bitcoin.PaymentChannel.Internal.State +import Data.Bitcoin.PaymentChannel.Internal.Script +import Data.Bitcoin.PaymentChannel.Internal.Payment +import Data.Bitcoin.PaymentChannel.Internal.Util + +import qualified Network.Haskoin.Transaction as HT +import qualified Network.Haskoin.Crypto as HC +import qualified Network.Haskoin.Script as HS + +getUnsignedRefundTx :: PaymentChannelState -> BitcoinAmount -> HT.Tx +getUnsignedRefundTx st txFee = -- @CPaymentChannelState = + let + (baseTx,_) = getPaymentTxForSigning st 0 --create empty payment tx, which redeems funding tx + refundOut = HT.TxOut (toWord64 $ pcsChannelTotalValue st - txFee) (pcsClientChange st) + in + baseTx { HT.txOut = [refundOut] } + +getRefundTxHashForSigning :: + PaymentChannelState + -> BitcoinAmount -- ^Bitcoin transaction fee + -> HC.Hash256 +getRefundTxHashForSigning pcs@(CPaymentChannelState cp _ _ _ _) newValueLeft = + HS.txSigHash tx (getRedeemScript cp) 0 (HS.SigAll False) + where tx = getUnsignedRefundTx pcs newValueLeft + +refundTxAddSignature :: + PaymentChannelState + -> BitcoinAmount -- ^Bitcoin tx fee + -> HC.Signature -- ^Signature over 'getUnsignedRefundTx' which verifies against clientPubKey + -> FinalTx +refundTxAddSignature pcs@(CPaymentChannelState cp _ _ _ _) txFee clientRawSig = + let + inputScript = getInputScript cp $ refundTxScriptSig clientRawSig + in + replaceScriptInput (serialize inputScript) $ getUnsignedRefundTx pcs txFee + diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Script.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Script.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Script.hs @@ -0,0 +1,82 @@ +-- {-# OPTIONS_GHC -fwarn-incomplete-patterns -Werror #-} + +module Data.Bitcoin.PaymentChannel.Internal.Script where + +import Data.Bitcoin.PaymentChannel.Internal.Types +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 + +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 :: HC.PubKey -> HC.PubKey -> Word32 -> Script +paymentChannelRedeemScript clientPK serverPK lockTime = Script + [OP_IF, + opPushData (serialize serverPK), OP_CHECKSIGVERIFY, + OP_ELSE, + encodeScriptInt lockTime, op_CHECKLOCKTIMEVERIFY, OP_DROP, + OP_ENDIF, + opPushData (serialize 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/Settlement.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Settlement.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Settlement.hs @@ -0,0 +1,54 @@ +module Data.Bitcoin.PaymentChannel.Internal.Settlement where + +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.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 + + +getSettlementTxForSigning :: + PaymentChannelState + -> BitcoinAmount -- ^Bitcoin transaction fee for final payment transaction + -> (HT.Tx, HS.SigHash) -- ^ Transaction plus valueReceiver SigHash +getSettlementTxForSigning st@(CPaymentChannelState _ fti@(CFundingTxInfo _ _ channelTotalValue) + (CPaymentTxConfig sendChg recvChg) senderVal (Just (CPaymentSignature sig sigHash))) 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 (toWord64 receiverAmount) recvChg + in + paymentTxAddOutput recvOut adjTx +getSettlementTxForSigning _ _ = error "no payment sig available" + +getSettlementTxHashForSigning :: + PaymentChannelState + -> BitcoinAmount -- ^Bitcoin transaction fee + -> HC.Hash256 +getSettlementTxHashForSigning pcs@(CPaymentChannelState cp _ _ _ _) txFee = + HS.txSigHash tx (getRedeemScript cp) 0 sigHash + where (tx,sigHash) = getSettlementTxForSigning pcs txFee + +getSignedSettlementTx :: + PaymentChannelState + -> BitcoinAmount -- ^Bitcoin tx fee + -> HC.Signature -- ^Signature over 'getSettlementTxHashForSigning' which verifies against serverPubKey + -> Either PayChanError FinalTx +getSignedSettlementTx pcs@(CPaymentChannelState + cp@(CChannelParameters senderPK rcvrPK lt) _ _ _ (Just clientSig)) txFee serverRawSig = + let + (tx,recvSigHash) = getSettlementTxForSigning pcs txFee + serverSig = CPaymentSignature serverRawSig recvSigHash + inputScript = getInputScript cp $ paymentTxScriptSig clientSig serverSig + in + Right $ replaceScriptInput (serialize inputScript) tx +getSignedSettlementTx (CPaymentChannelState _ _ _ _ Nothing) _ _ = Left NoValueTransferred + + diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/State.hs b/src/Data/Bitcoin/PaymentChannel/Internal/State.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitcoin/PaymentChannel/Internal/State.hs @@ -0,0 +1,41 @@ +-- {-# OPTIONS_GHC -fwarn-incomplete-patterns -Werror #-} + +module Data.Bitcoin.PaymentChannel.Internal.State where + +import Data.Bitcoin.PaymentChannel.Internal.Types +import Data.Bitcoin.PaymentChannel.Internal.Error + +import qualified Network.Haskoin.Transaction as HT + +pcsChannelTotalValue = ftiOutValue . pcsFundingTxInfo +pcsValueTransferred cs = pcsChannelTotalValue cs - pcsValueLeft cs +pcsChannelValueLeft = pcsValueLeft +pcsClientPubKey = cpSenderPubKey . pcsParameters +pcsServerPubKey = cpReceiverPubKey . pcsParameters +pcsClientChange = ptcSenderChangeScript . pcsPaymentConfig +pcsServerChange = ptcReceiverChangeScript . pcsPaymentConfig +pcsLockTime = cpLockTime . pcsParameters +pcsChannelID = ftiHash . pcsFundingTxInfo + + +-- pcsChannelIsExhausted cs = maybe False (\pSig -> psSigHash pSig == ) (pcsPaymentSignature cs) + +newPaymentChannelState channelParameters fundingTxInfo paymentConfig = + CPaymentChannelState { + pcsParameters = channelParameters, + pcsFundingTxInfo = fundingTxInfo, + pcsPaymentConfig = paymentConfig, + pcsValueLeft = ftiOutValue fundingTxInfo, + pcsPaymentSignature = Nothing + } + +-- |Update state with verified payment +updatePaymentChannelState :: + PaymentChannelState + -> Payment + -> Either PayChanError PaymentChannelState +updatePaymentChannelState pcs@(CPaymentChannelState par fun pconf oldSenderVal oldSig) + (CPayment newSenderVal newSig) + | newSenderVal <= oldSenderVal = + Right $ CPaymentChannelState par fun pconf newSenderVal (Just newSig) + | otherwise = Left BadPayment diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Types.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Types.hs @@ -0,0 +1,128 @@ +module Data.Bitcoin.PaymentChannel.Internal.Types where + +import Data.Bitcoin.PaymentChannel.Internal.Util +import Data.Bitcoin.PaymentChannel.Internal.Version + +import qualified Network.Haskoin.Transaction as HT +import qualified Network.Haskoin.Crypto as HC +import qualified Network.Haskoin.Script as HS +import qualified Data.ByteString as B +import Data.Word (Word32, Word64, Word8) +import qualified Data.Binary as Bin +import qualified Data.Binary.Put as BinPut +import qualified Data.Binary.Get as BinGet + +dUST_LIMIT = 700 :: Word64 +mIN_CHANNEL_SIZE = dUST_LIMIT * 2 +pROTOCOL_VERSION = CVersion 2 0 + +newtype UnsignedPaymentTx = CUnsignedPaymentTx { unsignedTx :: HT.Tx } deriving Show +type FinalTx = HT.Tx + +-- |Shared state object used by both value sender and value receiver. +data PaymentChannelState = CPaymentChannelState { + pcsParameters :: ChannelParameters, + pcsFundingTxInfo :: FundingTxInfo, + pcsPaymentConfig :: PaymentTxConfig, + -- |Value left to send + pcsValueLeft :: BitcoinAmount, + -- |Signature over payment transaction of value 'pcsValueLeft' + -- unless no payment has been made yet + pcsPaymentSignature :: Maybe PaymentSignature +} deriving (Eq, Show) + +-- |Holds information about the channel +data ChannelParameters = CChannelParameters { + cpSenderPubKey :: HC.PubKey, + cpReceiverPubKey :: HC.PubKey, + -- |Channel expiration date/time + cpLockTime :: BitcoinLockTime +} deriving (Eq, Show) + +-- |Holds information about the Bitcoin transaction used to fund +-- the channel +data FundingTxInfo = CFundingTxInfo { + ftiHash :: HT.TxHash, -- ^ Hash of funding transaction. + ftiOutIndex :: Word32, -- ^ Index/"vout" of funding output + ftiOutValue :: BitcoinAmount -- ^ Value of funding output (channel max value) +} deriving (Eq, Show) + +-- |Holds information about how to construct the payment transaction +data PaymentTxConfig = CPaymentTxConfig { + -- |Value sender change scriptPubKey in Bitcoin payment transaction + ptcSenderChangeScript :: B.ByteString, + -- |Value receiver destination scriptPubKey in Bitcoin payment transaction + ptcReceiverChangeScript :: B.ByteString +} deriving (Eq, Show) + +-- |Used to transfer value from sender to receiver. +data Payment = CPayment { + -- |Channel value remaining ('pcsValueLeft' of the state from which this payment was made) + cpChannelValueLeft :: BitcoinAmount, + -- |Payment signature + cpSignature :: PaymentSignature +} + +-- |Contains payment signature plus sig hash flag byte +data PaymentSignature = CPaymentSignature { + psSig :: HC.Signature + ,psSigHash :: HS.SigHash +} deriving (Eq, Show) + +------SERIALIZATION-------- + +instance Bin.Binary PaymentChannelState where + put (CPaymentChannelState par fti payConf valLeft (Just 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 + get = CPaymentChannelState <$> Bin.get <*> Bin.get <*> + Bin.get <*> Bin.get <*> (BinGet.getWord8 >>= + \w -> case w of + 1 -> fmap Just Bin.get + _ -> return Nothing) + +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.Binary 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 + put (CPaymentTxConfig sendScript recvScript) = + Bin.put sendScript >> Bin.put recvScript + get = CPaymentTxConfig <$> Bin.get <*> Bin.get + +instance Bin.Binary PaymentSignature where + put ps = Bin.put (psSig ps) + >> Bin.put (psSigHash ps) + get = CPaymentSignature <$> Bin.get <*> Bin.get + +instance Bin.Binary Payment where + put (CPayment val sig) = Bin.put val >> Bin.put sig + get = CPayment <$> Bin.get <*> Bin.get + + +-- Universally unique payment. +-- Contains the necessary information to identify the channel +-- over which the payment was sent, the signature (including SigHash flag) +-- and amount (for verification), as well as the protocol version. +-- data ChannelPayment = CChannelPayment { +-- -- |Payment protocol version (currently 2.x) +-- cpVersion :: Version, +-- -- |Channel ID is the regular Bitcoin double-SHA256 hash of the funding transaction +-- cpChannelID :: HT.TxHash, +-- cpPayment :: Payment, +-- -- |Optional info field +-- cpInfo :: Maybe BS.ByteString +-- } + +instance Show Payment where + show (CPayment val sig) = + "" diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Util.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Util.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Data.Bitcoin.PaymentChannel.Internal.Util where + +import Data.String (fromString) +import qualified Data.Serialize as Ser (Serialize, encode, get, put) +import qualified Data.Serialize.Put as SerPut (putWord64be) +import qualified Data.Serialize.Get as SerGet (getWord64be) +import qualified Data.Binary as Bin +import Data.Binary.Put (putWord32le) +import Data.Binary.Get (getWord32le, runGetOrFail) +import Data.Word +import Data.Time.Clock +import Data.Time.Clock.POSIX +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 + +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 + +toHexBS :: B.ByteString -> B.ByteString +toHexBS = B16.encode + +fromHexString :: String -> B.ByteString +fromHexString hexStr = + case (B16.decode . C.pack) hexStr of + (bs,e) -> + if B.length e /= 0 then B.empty else bs + + +-- |Represents a bitcoin amount as number of satoshis. +-- 1 satoshi = 1e-8 bitcoins. +-- Integer operations will never over- or underflow with this type. +-- Convert to a Word64 using 'toWord64', which caps the final amount. +newtype BitcoinAmount = CMoneyAmount Integer + deriving (Eq, Ord, Num, Enum, Real, Integral, Bin.Binary) +instance Show BitcoinAmount where + show ma = show (fromIntegral $ toWord64 ma) ++ " satoshis" + +-- | Convert to 'Word64', with zero as floor, UINT64_MAX as ceiling +toWord64 :: BitcoinAmount -> Word64 +toWord64 (CMoneyAmount i) = fromIntegral $ + max 0 cappedValue + where + cappedValue = min i $ fromIntegral (maxBound :: Word64) + +instance Ser.Serialize BitcoinAmount where + put = SerPut.putWord64be . toWord64 + get = CMoneyAmount . fromIntegral <$> SerGet.getWord64be + + +-- | 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) + +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 + +deserEither :: Bin.Binary a => B.ByteString -> Either String a +deserEither bs = + case runGetOrFail Bin.get (BL.fromStrict bs) of + Left (_,_,e) -> Left e + Right (_,_,res) -> Right res + +----------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 scriptIn (HT.Tx v [] txOut lt) = + 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 = + LockTimeBlockHeight Word32 | + LockTimeDate UTCTime deriving (Eq, Show) + +-- | Convert from Bitcoin format ('Word32') +parseBitcoinLocktime :: Word32 -> BitcoinLockTime +parseBitcoinLocktime i + | i < 500000000 = LockTimeBlockHeight i + | i >= 500000000 = LockTimeDate $ posixSecondsToUTCTime (fromIntegral i) + | otherwise = error "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 + + + +instance Bin.Binary BitcoinLockTime where + put = putWord32le . toWord32 + get = parseBitcoinLocktime <$> getWord32le + + +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 new file mode 100644 --- /dev/null +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Version.hs @@ -0,0 +1,8 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Data/Bitcoin/PaymentChannel/Types.hs @@ -0,0 +1,91 @@ +{-| +Module : Data.Bitcoin.PaymentChannel.Types +Copyright : (c) Rune K. Svendsen, 2016 +License : PublicDomain +Maintainer : runesvend@gmail.com + +Types used with the interface provided by "Data.Bitcoin.PaymentChannel". + +-} + +module Data.Bitcoin.PaymentChannel.Types +( +SenderPaymentChannel(..), +ReceiverPaymentChannel(..), +Payment, +FundingTxInfo(..), +ChannelParameters(..), +PayChanError, + +BitcoinAmount, toWord64, +PaymentChannel(..), +BitcoinLockTime, fromDate +) +where + +import Data.Bitcoin.PaymentChannel.Internal.Types + (PaymentChannelState(..), Payment + ,FundingTxInfo(..), ChannelParameters(..)) +import Data.Bitcoin.PaymentChannel.Internal.Util + (BitcoinAmount, toWord64, + BitcoinLockTime, fromDate) +import Data.Bitcoin.PaymentChannel.Internal.State (pcsChannelID, pcsChannelTotalValue) +import Data.Bitcoin.PaymentChannel.Internal.Error (PayChanError(..)) + +import qualified Network.Haskoin.Crypto as HC +import qualified Network.Haskoin.Transaction as HT + + +-- |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 +} + +-- |State object for the value receiver +data ReceiverPaymentChannel = CReceiverPaymentChannel { + -- |Internal state object + rpcState :: PaymentChannelState, + -- |Used to verify signatures from value sender. + rpcVerifyFunc :: HC.Hash256 -> HC.PubKey -> HC.Signature -> Bool, + -- |Function which produces a signature that verifies against 'cpReceiverPubKey'. + -- Used to produce the Bitcoin transaction that closes the channel. + rpcSignFunc :: HC.Hash256 -> HC.Signature +} + +-- |Get various information about an open payment channel. +class PaymentChannel a where + -- |Get value sent to receiver/left for sender + valueToMe :: a -> BitcoinAmount + -- |Retrieve internal channel state + getChannelState :: a -> PaymentChannelState + -- |Get channel ID + getChannelID :: a -> HT.TxHash + -- |Returns 'True' if all available channel value has been transferred, 'False' otherwise + channelIsExhausted :: a -> Bool + + getChannelID = pcsChannelID . getChannelState + channelIsExhausted pch = pcsValueLeft (getChannelState pch) == 0 --TODO: payment sigHash == SigSingle + +instance PaymentChannel SenderPaymentChannel where + valueToMe (CSenderPaymentChannel s _) = + pcsValueLeft s + getChannelState = spcState + +instance PaymentChannel ReceiverPaymentChannel where + valueToMe (CReceiverPaymentChannel s _ _) = + pcsChannelTotalValue s - pcsValueLeft s + getChannelState = rpcState + + +instance Show SenderPaymentChannel where + show (CSenderPaymentChannel s _) = + "" + +instance Show ReceiverPaymentChannel where + show (CReceiverPaymentChannel s _ _) = + "" diff --git a/src/Data/Bitcoin/PaymentChannel/Util.hs b/src/Data/Bitcoin/PaymentChannel/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitcoin/PaymentChannel/Util.hs @@ -0,0 +1,33 @@ +{-| +Module : Data.Bitcoin.PaymentChannel.Types +Copyright : (c) Rune K. Svendsen, 2016 +License : PublicDomain +Maintainer : runesvend@gmail.com + +Utility functions for "Data.Bitcoin.PaymentChannel". + +-} + +module Data.Bitcoin.PaymentChannel.Util +( +getFundingAddress, + +BitcoinLockTime, parseBitcoinLocktime, toWord32, fromDate +) +where + +import Data.Bitcoin.PaymentChannel.Internal.Script + (getP2SHFundingAddress) +import Data.Bitcoin.PaymentChannel.Internal.Util + (BitcoinLockTime, parseBitcoinLocktime, toWord32, fromDate) + +-- Only used to make Haddock display the right link +import Data.Bitcoin.PaymentChannel.Types + (ChannelParameters, FundingTxInfo) + +-- | Derive a Bitcoin address, for funding a payment channel, from +-- 'ChannelParameters'. +-- The transaction which pays to this address is the channel funding transaction, +-- and information about this transaction is contained in +-- 'FundingTxInfo'. +getFundingAddress = getP2SHFundingAddress