diff --git a/bitcoin-payment-channel.cabal b/bitcoin-payment-channel.cabal --- a/bitcoin-payment-channel.cabal +++ b/bitcoin-payment-channel.cabal @@ -1,5 +1,5 @@ name: bitcoin-payment-channel -version: 0.1.0.0 +version: 0.1.1.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. @@ -39,17 +39,40 @@ Data.Bitcoin.PaymentChannel.Internal.Settlement, Data.Bitcoin.PaymentChannel.Internal.State, Data.Bitcoin.PaymentChannel.Internal.Types, + Data.Bitcoin.PaymentChannel.Internal.Serialization, Data.Bitcoin.PaymentChannel.Internal.Util, Data.Bitcoin.PaymentChannel.Internal.Version - ghc-options: -fwarn-incomplete-patterns +-- ghc-options: -Wall - build-depends: base >= 4.7 && < 5, + build-depends: base, bytestring, text, base16-bytestring, base58string, hexstring, + base64-bytestring, time, - cereal, binary, + cereal, binary, aeson, scientific, haskoin-core - hs-source-dirs: src + + default-language: Haskell2010 + +executable Test + main-is: Main.hs + +-- default-extensions: FlexibleContexts + +-- other-modules: + +-- ghc-options: -Wall + + build-depends: base >= 4.7 && < 5, + bytestring, text, base16-bytestring, base58string, hexstring, + base64-bytestring, + time, + cereal, binary, aeson, + haskoin-core, + QuickCheck, + bitcoin-payment-channel + + hs-source-dirs: test default-language: Haskell2010 diff --git a/src/Data/Bitcoin/PaymentChannel.hs b/src/Data/Bitcoin/PaymentChannel.hs --- a/src/Data/Bitcoin/PaymentChannel.hs +++ b/src/Data/Bitcoin/PaymentChannel.hs @@ -47,11 +47,7 @@ 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. + as was provided by the sender, and, in addition, the first channel 'Payment', received from the sender. 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 @@ -66,10 +62,16 @@ transaction pays the total value transmitted over the channel to the receiver and the rest back to the sender. +A settlement transaction can be produced by the value receiver using 'getSettlementBitcoinTx'. + The receiver will want to use @flip 'Network.Haskoin.Crypto.signMsg' receiverPrivKey@ as the + signing function passed to 'getSettlementBitcoinTx', +where @receiverPrivKey@ is the private key from which 'cpReceiverPubKey' is derived. + + __/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/ + /but it is paramount that the value receiver get 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/ @@ -113,6 +115,7 @@ 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'. @@ -123,12 +126,13 @@ 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 amount = - let pConf = CPaymentTxConfig (bitcoinPayPKBS sendPK) (bitcoinPayPKBS recvPK) in + fundInf@(CFundingTxInfo hash idx chanVal) signFunc sendAddr amount = + let pConf = CPaymentTxConfig sendAddr in sendPayment (CSenderPaymentChannel (newPaymentChannelState cp fundInf pConf) signFunc) amount @@ -169,16 +173,15 @@ 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' + -> HC.Address -- ^ Value sender/client change address -> Payment -- ^Initial channel payment -> Either PayChanError ReceiverPaymentChannel -- ^Receiver state object channelFromInitialPayment cp@(CChannelParameters sendPK recvPK _) - fundInf signFunc paymnt = + fundInf sendAddr paymnt = let - verifyFunc hash pk sig = HC.verifySig hash sig pk - pConf = CPaymentTxConfig (bitcoinPayPKBS sendPK) (bitcoinPayPKBS recvPK) + pConf = CPaymentTxConfig sendAddr eitherNewState = flip recvPayment paymnt $ CReceiverPaymentChannel - (newPaymentChannelState cp fundInf pConf) verifyFunc signFunc + (newPaymentChannelState cp fundInf pConf) in mapRight snd eitherNewState @@ -189,7 +192,8 @@ 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 = +recvPayment rpc@(CReceiverPaymentChannel cs) paymnt = + let verifyFunc hash pk sig = HC.verifySig hash sig pk in if verifyPayment cs paymnt verifyFunc then updatePaymentChannelState cs paymnt >>= (\newState -> Right (pcsValueLeft cs - cpChannelValueLeft paymnt, rpc { rpcState = newState })) @@ -205,10 +209,12 @@ -- 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 -> Either PayChanError HT.Tx -- ^Settling Bitcoin transaction -getSettlementBitcoinTx (CReceiverPaymentChannel cs verifyFunc signFunc) txFee = - getSignedSettlementTx cs txFee serverSig - where serverSig = signFunc (getSettlementTxHashForSigning cs txFee) +getSettlementBitcoinTx (CReceiverPaymentChannel cs) signFunc recvAddr txFee = + getSignedSettlementTx cs recvAddr txFee serverSig + where serverSig = signFunc (getSettlementTxHashForSigning cs recvAddr txFee) diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Payment.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Payment.hs --- a/src/Data/Bitcoin/PaymentChannel/Internal/Payment.hs +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Payment.hs @@ -15,7 +15,7 @@ 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 @@ -24,24 +24,27 @@ (HT.OutPoint hash idx) B.empty maxBound] - [] - 0 + [] --no outputs + 0 --lockTime 0 paymentTxAddOutput :: HT.TxOut -> HT.Tx -> (HT.Tx, HS.SigHash) paymentTxAddOutput addOut tx@(HT.Tx _ _ outs _) - | HT.outValue addOut >= dUST_LIMIT = + | HT.outValue addOut >= fromIntegral dUST_LIMIT = (tx { HT.txOut = outs ++ [addOut] }, HS.SigSingle True) | otherwise = (tx, HS.SigNone True) +---Payment Tx builer--- + + getPaymentTxForSigning :: PaymentChannelState -> BitcoinAmount -- ^New sender value (newValueLeft) -> (HT.Tx, HS.SigHash) getPaymentTxForSigning st@(CPaymentChannelState _ fti - (CPaymentTxConfig sendChg _) chanValLeft _) newValueLeft = + (CPaymentTxConfig sendAddr) chanValLeft _) newValueLeft = paymentTxAddOutput senderOut $ buildEmptyPaymentTx fti - where senderOut = HT.TxOut (toWord64 newValueLeft) sendChg + where senderOut = HT.TxOut (toWord64 newValueLeft) (addressToScriptPubKeyBS sendAddr) getPaymentTxHashForSigning :: PaymentChannelState @@ -52,6 +55,7 @@ (HS.txSigHash tx (getRedeemScript cp) 0 sigHash, sigHash) where (tx,sigHash) = getPaymentTxForSigning st newValueLeft +---Payment build/verify--- verifyPayment :: PaymentChannelState -> Payment @@ -84,9 +88,9 @@ --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" - + _ -> error + "BUG: unsupported SigHash created by 'getPaymentTxHashForSigning'" +---Payment build/verify--- diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Script.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Script.hs --- a/src/Data/Bitcoin/PaymentChannel/Internal/Script.hs +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Script.hs @@ -3,12 +3,14 @@ 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 diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Serialization.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Serialization.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Serialization.hs @@ -0,0 +1,99 @@ +module Data.Bitcoin.PaymentChannel.Internal.Serialization where + +import Data.Bitcoin.PaymentChannel.Internal.Types +import Data.Bitcoin.PaymentChannel.Internal.Util + (BitcoinAmount(..), toWord64, 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.ByteString.Base64 as B64 + +import Debug.Trace + + + +instance Show Payment where + show (CPayment val sig) = + "" + +-------JSON-------- +instance ToJSON Payment where + toJSON = toJSON . decodeLatin1 . B64.encode . toStrict . Bin.encode + +instance FromJSON Payment where + parseJSON = withText "Payment" $ + \b64 -> + failOnLeftWith "failed to deserialize binary data: " =<< + (\h -> show (toHexString h) `trace` binaryDeser h) =<< + failOnLeftWith "failed to parse base64 data: " =<< b64Decode b64 + where + b64Decode = return . B64.decode . encodeUtf8 + binaryDeser = return . deserEither + failOnLeftWith e = either (fail . (e ++)) return + +instance ToJSON BitcoinAmount where + toJSON amt = Number $ scientific + (fromIntegral $ toWord64 amt) 0 + +instance FromJSON BitcoinAmount where + parseJSON = withScientific "BitcoinAmount" $ + fmap fromIntegral . parseJSONInt + +-- Needed to convert from Scientific +instance Bounded BitcoinAmount where + minBound = CMoneyAmount 0 + maxBound = CMoneyAmount $ round $ 21e6 * 1e8 + +parseJSONInt :: Scientific -> Parser Integer +parseJSONInt s = + case toBoundedInteger s of + Just (CMoneyAmount i) -> return i + Nothing -> fail $ "failed to decode JSON number to integer. data: " ++ show s + + +------BINARY-------- +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 sendAddr) = + Bin.put sendAddr + get = CPaymentTxConfig <$> Bin.get + +instance Bin.Binary 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) + get = CPaymentSignature <$> Bin.get <*> Bin.get + diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Settlement.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Settlement.hs --- a/src/Data/Bitcoin/PaymentChannel/Internal/Settlement.hs +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Settlement.hs @@ -15,40 +15,43 @@ 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) - (CPaymentTxConfig sendChg recvChg) senderVal (Just (CPaymentSignature sig sigHash))) txFee = + _ 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 (toWord64 receiverAmount) recvChg + recvOut = HT.TxOut (toWord64 receiverAmount) (addressToScriptPubKeyBS recvAddr) in paymentTxAddOutput recvOut adjTx -getSettlementTxForSigning _ _ = error "no payment sig available" +getSettlementTxForSigning _ _ _ = error "no payment sig available" getSettlementTxHashForSigning :: PaymentChannelState + -> HC.Address -> BitcoinAmount -- ^Bitcoin transaction fee -> HC.Hash256 -getSettlementTxHashForSigning pcs@(CPaymentChannelState cp _ _ _ _) txFee = +getSettlementTxHashForSigning pcs@(CPaymentChannelState cp _ _ _ _) recvAddr txFee = HS.txSigHash tx (getRedeemScript cp) 0 sigHash - where (tx,sigHash) = getSettlementTxForSigning pcs txFee + where (tx,sigHash) = getSettlementTxForSigning pcs recvAddr txFee getSignedSettlementTx :: PaymentChannelState - -> BitcoinAmount -- ^Bitcoin tx fee + -> HC.Address -- ^Receiver/server change address + -> 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 = + cp@(CChannelParameters senderPK rcvrPK lt) _ _ _ (Just clientSig)) recvAddr txFee serverRawSig = let - (tx,recvSigHash) = getSettlementTxForSigning pcs txFee + (tx,recvSigHash) = getSettlementTxForSigning pcs recvAddr txFee serverSig = CPaymentSignature serverRawSig recvSigHash inputScript = getInputScript cp $ paymentTxScriptSig clientSig serverSig in Right $ replaceScriptInput (serialize inputScript) tx -getSignedSettlementTx (CPaymentChannelState _ _ _ _ Nothing) _ _ = Left NoValueTransferred +getSignedSettlementTx (CPaymentChannelState _ _ _ _ Nothing) _ _ _ = Left NoValueTransferred diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/State.hs b/src/Data/Bitcoin/PaymentChannel/Internal/State.hs --- a/src/Data/Bitcoin/PaymentChannel/Internal/State.hs +++ b/src/Data/Bitcoin/PaymentChannel/Internal/State.hs @@ -4,18 +4,29 @@ import Data.Bitcoin.PaymentChannel.Internal.Types import Data.Bitcoin.PaymentChannel.Internal.Error +import Data.Bitcoin.PaymentChannel.Internal.Util (addressToScriptPubKeyBS) import qualified Network.Haskoin.Transaction as HT +import qualified Network.Haskoin.Crypto as HC pcsChannelTotalValue = ftiOutValue . pcsFundingTxInfo pcsValueTransferred cs = pcsChannelTotalValue cs - pcsValueLeft cs pcsChannelValueLeft = pcsValueLeft pcsClientPubKey = cpSenderPubKey . pcsParameters pcsServerPubKey = cpReceiverPubKey . pcsParameters -pcsClientChange = ptcSenderChangeScript . pcsPaymentConfig -pcsServerChange = ptcReceiverChangeScript . pcsPaymentConfig +pcsClientChangeAddress = ptcSenderChangeAddress . pcsPaymentConfig +pcsClientChange = addressToScriptPubKeyBS . pcsClientChangeAddress pcsLockTime = cpLockTime . pcsParameters pcsChannelID = ftiHash . pcsFundingTxInfo + +-- |Set new client/sender change address. +-- Use this function if the client wishes to change its change address. +-- First set the new change address using this function, then accept the payment which +-- uses this new change address. +setClientChangeAddress :: PaymentChannelState -> HC.Address -> PaymentChannelState +setClientChangeAddress pcs@(CPaymentChannelState _ _ pConf _ _) addr = + pcs { pcsPaymentConfig = newPayConf } + where newPayConf = pConf { ptcSenderChangeAddress = addr } -- pcsChannelIsExhausted cs = maybe False (\pSig -> psSigHash pSig == ) (pcsPaymentSignature cs) diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Types.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Types.hs --- a/src/Data/Bitcoin/PaymentChannel/Internal/Types.hs +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Types.hs @@ -12,7 +12,7 @@ import qualified Data.Binary.Put as BinPut import qualified Data.Binary.Get as BinGet -dUST_LIMIT = 700 :: Word64 +dUST_LIMIT = 700 :: BitcoinAmount mIN_CHANNEL_SIZE = dUST_LIMIT * 2 pROTOCOL_VERSION = CVersion 2 0 @@ -21,17 +21,20 @@ -- |Shared state object used by both value sender and value receiver. data PaymentChannelState = CPaymentChannelState { + -- |Defined by the sender and receiver pcsParameters :: ChannelParameters, + -- |Retrieved by looking at the in-blockchain funding transaction pcsFundingTxInfo :: FundingTxInfo, + pcsPaymentConfig :: PaymentTxConfig, - -- |Value left to send + -- |Value left to send (starts at @ftiOutValue . pcsFundingTxInfo@) 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 +-- |Defines sender, receiver, and expiration date of the channel data ChannelParameters = CChannelParameters { cpSenderPubKey :: HC.PubKey, cpReceiverPubKey :: HC.PubKey, @@ -50,9 +53,9 @@ -- |Holds information about how to construct the payment transaction data PaymentTxConfig = CPaymentTxConfig { -- |Value sender change scriptPubKey in Bitcoin payment transaction - ptcSenderChangeScript :: B.ByteString, + ptcSenderChangeAddress :: HC.Address -- |Value receiver destination scriptPubKey in Bitcoin payment transaction - ptcReceiverChangeScript :: B.ByteString +-- ptcReceiverChangeScript :: B.ByteString } deriving (Eq, Show) -- |Used to transfer value from sender to receiver. @@ -61,54 +64,21 @@ cpChannelValueLeft :: BitcoinAmount, -- |Payment signature cpSignature :: PaymentSignature -} +} deriving (Eq) -- |Contains payment signature plus sig hash flag byte data PaymentSignature = CPaymentSignature { psSig :: HC.Signature + -- |SigHash flag. Denotes whether the sender still wants its change output + -- included in the settling transaction. In case of (SigNone True), the + -- value sender has given up the rest of the channel value, leaving + -- everything to the receiver. This is necessary so that no settling + -- transaction containing an output below the "dust limit" is produced. ,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) @@ -123,6 +93,3 @@ -- 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 --- a/src/Data/Bitcoin/PaymentChannel/Internal/Util.hs +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Util.hs @@ -7,6 +7,8 @@ import qualified Data.Serialize.Put as SerPut (putWord64be) import qualified Data.Serialize.Get as SerGet (getWord64be) 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, runGetOrFail) import Data.Word @@ -45,7 +47,7 @@ -- 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) + deriving (Eq, Ord, Num, Enum, Real, Integral) instance Show BitcoinAmount where show ma = show (fromIntegral $ toWord64 ma) ++ " satoshis" @@ -56,6 +58,10 @@ where cappedValue = min i $ fromIntegral (maxBound :: Word64) +instance Bin.Binary BitcoinAmount where + put = BinPut.putWord64le . toWord64 + get = CMoneyAmount . fromIntegral <$> BinGet.getWord64le + instance Ser.Serialize BitcoinAmount where put = SerPut.putWord64be . toWord64 get = CMoneyAmount . fromIntegral <$> SerGet.getWord64be @@ -75,6 +81,15 @@ 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 @@ -110,7 +125,11 @@ -- Derive a 'BitcoinLockTime' from a 'Data.Time.Clock.UTCTime' using 'fromDate'. data BitcoinLockTime = LockTimeBlockHeight Word32 | - LockTimeDate UTCTime deriving (Eq, Show) + LockTimeDate UTCTime deriving (Eq) + +instance Show BitcoinLockTime where + show (LockTimeBlockHeight blockNum) = "block number " ++ show blockNum + show (LockTimeDate date) = show date -- | Convert from Bitcoin format ('Word32') parseBitcoinLocktime :: Word32 -> BitcoinLockTime diff --git a/src/Data/Bitcoin/PaymentChannel/Types.hs b/src/Data/Bitcoin/PaymentChannel/Types.hs --- a/src/Data/Bitcoin/PaymentChannel/Types.hs +++ b/src/Data/Bitcoin/PaymentChannel/Types.hs @@ -8,34 +8,66 @@ -} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Data.Bitcoin.PaymentChannel.Types ( +PaymentChannel(..), SenderPaymentChannel(..), ReceiverPaymentChannel(..), Payment, FundingTxInfo(..), ChannelParameters(..), -PayChanError, +PayChanError(..), +PaymentChannelState, BitcoinAmount, toWord64, -PaymentChannel(..), -BitcoinLockTime, fromDate +BitcoinLockTime, fromDate, + +-- Constants +dUST_LIMIT, +mIN_CHANNEL_SIZE ) where import Data.Bitcoin.PaymentChannel.Internal.Types - (PaymentChannelState(..), Payment - ,FundingTxInfo(..), ChannelParameters(..)) + (PaymentChannelState(..), Payment(..) + ,FundingTxInfo(..), ChannelParameters(..), + dUST_LIMIT, mIN_CHANNEL_SIZE) +import Data.Bitcoin.PaymentChannel.Internal.Serialization +-- () import Data.Bitcoin.PaymentChannel.Internal.Util - (BitcoinAmount, toWord64, + (BitcoinAmount(..), toWord64, BitcoinLockTime, fromDate) -import Data.Bitcoin.PaymentChannel.Internal.State (pcsChannelID, pcsChannelTotalValue) +import Data.Bitcoin.PaymentChannel.Internal.State (pcsChannelID, pcsChannelTotalValue, + setClientChangeAddress) import Data.Bitcoin.PaymentChannel.Internal.Error (PayChanError(..)) +import qualified Data.Binary as Bin import qualified Network.Haskoin.Crypto as HC import qualified Network.Haskoin.Transaction as HT +-- |Get various information about an open payment channel. +class PaymentChannel a where + -- |Get value sent to receiver/left for sender + valueToMe :: a -> BitcoinAmount + channelValueLeft :: a -> BitcoinAmount + -- |Retrieve internal state object + 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 + -- |For internal use + _setChannelState :: a -> PaymentChannelState -> a + channelValueLeft = pcsValueLeft . getChannelState + getChannelID = pcsChannelID . getChannelState + channelIsExhausted pch = pcsValueLeft (getChannelState pch) == 0 --TODO: payment sigHash == SigSingle + + + + -- |State object for the value sender data SenderPaymentChannel = CSenderPaymentChannel { -- |Internal state object @@ -47,45 +79,32 @@ } -- |State object for the value receiver -data ReceiverPaymentChannel = CReceiverPaymentChannel { +newtype ReceiverPaymentChannel = CReceiverPaymentChannel { -- |Internal state object - rpcState :: PaymentChannelState, + rpcState :: PaymentChannelState -- |Used to verify signatures from value sender. - rpcVerifyFunc :: HC.Hash256 -> HC.PubKey -> HC.Signature -> Bool, +-- 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 +-- rpcSignFunc :: HC.Hash256 -> HC.Signature +} deriving (Eq, Bin.Binary) instance PaymentChannel SenderPaymentChannel where valueToMe (CSenderPaymentChannel s _) = pcsValueLeft s getChannelState = spcState + _setChannelState spc s = spc { spcState = s } instance PaymentChannel ReceiverPaymentChannel where - valueToMe (CReceiverPaymentChannel s _ _) = + valueToMe (CReceiverPaymentChannel s) = pcsChannelTotalValue s - pcsValueLeft s getChannelState = rpcState - + _setChannelState rpc s = rpc { rpcState = s } instance Show SenderPaymentChannel where show (CSenderPaymentChannel s _) = "" instance Show ReceiverPaymentChannel where - show (CReceiverPaymentChannel s _ _) = + show (CReceiverPaymentChannel s) = "" diff --git a/src/Data/Bitcoin/PaymentChannel/Util.hs b/src/Data/Bitcoin/PaymentChannel/Util.hs --- a/src/Data/Bitcoin/PaymentChannel/Util.hs +++ b/src/Data/Bitcoin/PaymentChannel/Util.hs @@ -11,23 +11,40 @@ module Data.Bitcoin.PaymentChannel.Util ( getFundingAddress, +setSenderChangeAddress, -BitcoinLockTime, parseBitcoinLocktime, toWord32, fromDate +BitcoinLockTime, parseBitcoinLocktime, toWord32, fromDate, deserEither ) where +import Data.Bitcoin.PaymentChannel.Internal.Types + (PaymentChannelState(..), PaymentTxConfig(..)) +-- import Data.Bitcoin.PaymentChannel.Internal.State +-- (ptcSenderChangeAddress) import Data.Bitcoin.PaymentChannel.Internal.Script (getP2SHFundingAddress) import Data.Bitcoin.PaymentChannel.Internal.Util - (BitcoinLockTime, parseBitcoinLocktime, toWord32, fromDate) + (BitcoinLockTime, parseBitcoinLocktime, toWord32, fromDate, deserEither) +import Data.Bitcoin.PaymentChannel.Internal.State + (setClientChangeAddress) --- Only used to make Haddock display the right link import Data.Bitcoin.PaymentChannel.Types - (ChannelParameters, FundingTxInfo) +-- (ChannelParameters, FundingTxInfo) +import qualified Network.Haskoin.Crypto as HC + -- | 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 + +-- |Set new value sender change address +setSenderChangeAddress :: PaymentChannel a => a -> HC.Address -> a +setSenderChangeAddress pch addr = + _setChannelState pch (setClientChangeAddress (getChannelState pch) addr) + + + + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,100 @@ +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 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 Test.QuickCheck -- (elements, Gen, arbitrary, Property, quickCheck, (==>)) +import Test.QuickCheck.Monadic -- (assert, monadicIO, pick, pre, run) +import Debug.Trace + + +data ArbChannelPair = ArbChannelPair SenderPaymentChannel ReceiverPaymentChannel + deriving (Show) + +doPayment :: ArbChannelPair -> BitcoinAmount -> ArbChannelPair +doPayment (ArbChannelPair spc rpc) amount = + let + (pmn, newSpc) = sendPayment spc amount + eitherRpc = recvPayment rpc pmn + in + case eitherRpc of + Left e -> error (show e) + Right (rAmt, newRpc) -> ArbChannelPair newSpc newRpc + +instance Arbitrary ArbChannelPair where + arbitrary = mkChanPair + +mkChanPair :: Gen ArbChannelPair -- (Either String ArbChannelPair) +mkChanPair = do + -- sender key pair + ArbitraryPubKey sendPriv sendPK <- arbitrary + -- receiver key pair + ArbitraryPubKey recvPriv recvPK <- arbitrary + -- expiration date + lockTime <- arbitrary + let cp = CChannelParameters sendPK recvPK lockTime + + fti <- arbitrary + + -- total channel value + let chanAmount = fromIntegral $ ftiOutValue fti :: Integer + -- value of first payment + initPayAmount <- arbitrary -- fromIntegral <$> choose (0, chanAmount) + + let (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 recvChan -> return $ ArbChannelPair sendChan recvChan + +instance Arbitrary BitcoinLockTime where + arbitrary = fmap parseBitcoinLocktime arbitrary + +instance Arbitrary FundingTxInfo where + arbitrary = do + ArbitraryTxHash h <- arbitrary + i <- arbitrary + amt <- fmap fromIntegral + (choose (fromIntegral mIN_CHANNEL_SIZE, round $ 21e6 * 1e8 :: Integer)) + :: Gen BitcoinAmount + return $ CFundingTxInfo h i amt + +instance Arbitrary BitcoinAmount where + arbitrary = fmap fromIntegral (choose (0,round $ 21e6 * 1e8 :: Integer)) + +runChanPair :: ArbChannelPair -> [BitcoinAmount] -> ArbChannelPair +runChanPair chanPair l = foldl doPayment chanPair l + +checkChanPair :: ArbChannelPair -> Bool +checkChanPair (ArbChannelPair sendChan recvChan) = + ("valLeft: " ++ show (valueToMe sendChan)) `trace` + getChannelState recvChan == getChannelState sendChan +-- case getSettlementBitcoinTx sendChan 0 of +-- Left e -> False +-- Right tx -> True + +testChanPair :: ArbChannelPair -> [BitcoinAmount] -> Bool +testChanPair p al = checkChanPair (runChanPair p al) + +main :: IO () +main = do + quickCheckWith stdArgs -- { maxSuccess = 25 } + testChanPair +-- (verbose $ testChanPair) + + + +