packages feed

bitcoin-payment-channel 0.5.0.1 → 0.6.0.0

raw patch · 18 files changed

+477/−296 lines, 18 filesdep ~QuickCheck

Dependency ranges changed: QuickCheck

Files

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