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.4.0.1 +version: 0.5.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,7 +34,6 @@ exposed-modules: Data.Bitcoin.PaymentChannel Data.Bitcoin.PaymentChannel.Types Data.Bitcoin.PaymentChannel.Util - Data.Bitcoin.PaymentChannel.Movable -- Exposed for testing purposes Data.Bitcoin.PaymentChannel.Internal.State @@ -51,6 +50,7 @@ Data.Bitcoin.PaymentChannel.Internal.Util ghc-options: -W + default-language: Haskell2010 build-depends: base >= 4.7 && < 5, haskoin-core >= 0.4.0 && < 0.5.0, @@ -64,16 +64,18 @@ time >= 1.5.0 && < 1.7.0, aeson >= 0.11.0 && < 0.12.0, scientific >= 0.3.0 && < 0.4.0, - string-conversions >= 0.4 && < 0.5 + string-conversions >= 0.4 && < 0.5, + tagged >= 0.8 && < 1.0 hs-source-dirs: src - default-language: Haskell2010 -executable Test - main-is: Main.hs - - ghc-options: -W +test-suite test-bitcoin-payment-channel + type: exitcode-stdio-1.0 + main-is: Main.hs + default-language: Haskell2010 + hs-source-dirs: test + ghc-options: -W build-depends: base >= 4.7 && < 5, haskoin-core >= 0.4.0 && < 1.0.0, @@ -84,9 +86,5 @@ time, cereal, aeson, - QuickCheck, + QuickCheck, test-framework, test-framework-quickcheck2, 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 @@ -93,6 +93,7 @@ channelFromInitialPayment, recvPayment, + recvPaymentForClose, getSettlementBitcoinTx, getRefundBitcoinTx, @@ -102,9 +103,10 @@ where import Data.Bitcoin.PaymentChannel.Internal.Types - (PaymentTxConfig(..), Payment(..), FullPayment(..), pcsClientChangeVal) + (PaymentTxConfig(..), Payment(..), FullPayment(..), Config, + pcsConfig, pcsClientChangeVal, pcsParameters) import Data.Bitcoin.PaymentChannel.Internal.State - (newPaymentChannelState, updatePaymentChannelState) + (newPaymentChannelState, updatePaymentChannelState, isPastLockTimeDate) import qualified Data.Bitcoin.PaymentChannel.Internal.State as S import Data.Bitcoin.PaymentChannel.Internal.Payment (createPayment, paymentFromState, verifyPaymentSigFromState) @@ -116,8 +118,10 @@ import Data.Bitcoin.PaymentChannel.Util (getFundingAddress) import Data.Bitcoin.PaymentChannel.Types -import qualified Network.Haskoin.Crypto as HC -import qualified Network.Haskoin.Transaction as HT +import qualified Network.Haskoin.Crypto as HC +import qualified Network.Haskoin.Transaction as HT +import Data.Time.Clock (UTCTime(..)) +import Data.Time.Calendar (Day(..)) -- |Create a new 'SenderPaymentChannel'. @@ -125,25 +129,26 @@ -- 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, channel expiration date and "dust limit" - -> FundingTxInfo -- ^ Holds information about the transaction used to fund the channel - -> (HC.Hash256 -> HC.Signature) -- ^Used to sign payments from sender. When given a 'HC.Hash256', produces a signature that verifies against sender PubKey. + Config -- ^ Various configuration options. 'defaultConfig' contains sensible defaults. + -> ChannelParameters -- ^ Specifies channel sender and receiver, channel expiration date and "dust limit" + -> 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.Address -- ^ Value sender/client change address - -> BitcoinAmount -- ^ Value of initial payment. Must be greater than or equal to 'minimumInitialPayment' + -> BitcoinAmount -- ^ Value of initial payment. Can be zero. -> (BitcoinAmount, FullPayment, SenderPaymentChannel) -- ^Initial payment amount (may be capped), initial payment, and new sender state object -channelWithInitialPaymentOf cp fundInf signFunc sendAddr amount = +channelWithInitialPaymentOf cfg cp fundInf signFunc sendAddr amount = let pConf = CPaymentTxConfig sendAddr (CFullPayment (CPayment _ tmpSig) _ _ _) = createPayment cp fundInf sendAddr amount signFunc in flip sendPayment amount $ CSenderPaymentChannel - (newPaymentChannelState cp fundInf pConf tmpSig) signFunc + (newPaymentChannelState cfg cp fundInf pConf tmpSig) signFunc -- |Create new payment of specified value. sendPayment :: - SenderPaymentChannel -- ^Sender state object - -> BitcoinAmount -- ^ Amount to send (the actual payment amount is capped so that that, at minimu, the client change value equals the dust limit) - -> (BitcoinAmount, FullPayment, SenderPaymentChannel) -- ^ Actual amount sent, payment, and updated sender state object + SenderPaymentChannel -- ^ Sender state object + -> BitcoinAmount -- ^ Amount to send (the actual payment amount is capped) + -> (BitcoinAmount, FullPayment, SenderPaymentChannel) -- ^ Actual amount actually sent, payment, and updated sender state object sendPayment (CSenderPaymentChannel cs signFunc) amountToSend = let valSent = pcsClientChangeVal cs - newSenderValue @@ -175,39 +180,72 @@ -- 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.Address -- ^ Value sender/client change address - -> FullPayment -- ^Initial channel payment + UTCTime -- ^ Current time. Needed for payment verification. + -> Config -- ^ Various configuration options. 'defaultConfig' contains sensible defaults. + -> ChannelParameters -- ^ Specifies channel sender and receiver, plus channel expiration date + -> FundingTxInfo -- ^ Holds information about the Bitcoin transaction used to fund the channel + -> FullPayment -- ^ Initial channel payment -> Either PayChanError (BitcoinAmount, ReceiverPaymentChannel) -- ^Error or: value_received plus state object -channelFromInitialPayment cp fundInf sendAddr fp@(CFullPayment (CPayment _ sig) _ _ _) = +channelFromInitialPayment now cfg cp fundInf fp@(CFullPayment (CPayment _ sig) _ _ sendAddr) = let pConf = CPaymentTxConfig sendAddr in - flip recvPayment fp $ CReceiverPaymentChannel + flip (recvPayment now) fp $ CReceiverPaymentChannel -- Create a new state with the unverified signature; then verify the same signature in 'recvPayment' - (newPaymentChannelState 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 :: - ReceiverPaymentChannel -- ^Receiver state object - -> FullPayment -- ^Payment to verify and register + 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 rpc@(CReceiverPaymentChannel oldState) fp@(CFullPayment paymnt _ _ _) = - let - verifySenderPayment hash pk sig = HC.verifySig hash sig (getPubKey pk) - in - if verifyPaymentSigFromState oldState verifySenderPayment paymnt then - updatePaymentChannelState oldState fp >>= - (\newState -> Right ( - S.channelValueLeft oldState - S.channelValueLeft newState - , rpc { rpcState = newState }) - ) - else - Left SigVerifyFailed +recvPayment currentTime rpc@(CReceiverPaymentChannel oldState) fp@(CFullPayment paymnt _ _ _) = + updatePaymentChannelState oldState fp >>= + checkExpiration >>= + verifyPaymentSignature paymnt >>= + (\newState -> Right ( + S.channelValueLeft oldState - S.channelValueLeft newState + , rpc { rpcState = newState }) + ) + where checkExpiration s = + if isPastLockTimeDate currentTime (pcsConfig oldState) (pcsParameters oldState) then + Left ChannelExpired + else + Right s +verifyPaymentSignature :: + Payment -- ^Payment whose signature to verify + -> PaymentChannelState -- ^State object + -> Either PayChanError PaymentChannelState +verifyPaymentSignature paymnt state = + if verifyPaymentSigFromState state verifySenderPayment paymnt then + Right state + else + Left SigVerifyFailed + where verifySenderPayment hash pk sig = HC.verifySig hash sig (getPubKey pk) + +-- |Same as 'recvPayment' but accept only a payment of zero value +-- 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 = + recvPayment futureTimeStamp newAddressState fp >>= + \(amtRecv, newState) -> case amtRecv of + 0 -> Right newState + _ -> Left ClosingPaymentBadValue + where newAddressState = CReceiverPaymentChannel $ + S.setClientChangeAddress state (fpChangeAddr fp) + -- 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 + -- money back) + futureTimeStamp = UTCTime (ModifiedJulianDay 94183) 0 -- 100 years into the future from now -- |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 diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/LockTime.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/LockTime.hs --- a/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/LockTime.hs +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/LockTime.hs @@ -32,7 +32,7 @@ | i >= 500000000 = LockTimeDate $ posixSecondsToUTCTime (fromIntegral i) | otherwise = error "GHC bug?" --- | Convert to Bitcoin format ('Word32') +-- | Convert to Bitcoin format (uint32 UNIX timestamp) toWord32 :: BitcoinLockTime -> Word32 toWord32 (LockTimeBlockHeight i) = i toWord32 (LockTimeDate date) = diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Script.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Script.hs --- a/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Script.hs +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Script.hs @@ -65,7 +65,7 @@ getP2SHFundingAddress = scriptToP2SHAddress . getRedeemScript getRedeemScript :: ChannelParameters -> Script -getRedeemScript (CChannelParameters senderPK recvrPK lockTime _) = +getRedeemScript (CChannelParameters senderPK recvrPK lockTime) = paymentChannelRedeemScript senderPK recvrPK lockTime getRedeemScriptBS :: ChannelParameters -> B.ByteString diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Error.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Error.hs --- a/src/Data/Bitcoin/PaymentChannel/Internal/Error.hs +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Error.hs @@ -13,7 +13,9 @@ ChangeAddrMismatch Address | RedeemScriptMismatch Script | DustOutput BitcoinAmount | - PartialPaymentBadValue BitcoinAmount + PartialPaymentBadValue BitcoinAmount | + ClosingPaymentBadValue | + ChannelExpired deriving Generic instance Show PayChanError where @@ -29,3 +31,6 @@ " 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." ++ + " cannot receive value in closing payment." + show ChannelExpired = "channel too close to expiration date" 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 @@ -27,8 +27,8 @@ } fromState :: PaymentChannelState -> UnsignedPayment -fromState (CPaymentChannelState cp (CFundingTxInfo hash idx fundingVal) - (CPaymentTxConfig changeAddr) changeValue _) = +fromState (CPaymentChannelState _ cp (CFundingTxInfo hash idx fundingVal) + (CPaymentTxConfig changeAddr) _ changeValue _) = UnsignedPayment (HT.OutPoint hash idx) fundingVal (getRedeemScript cp) changeAddr changeValue @@ -63,7 +63,7 @@ -> BitcoinAmount -- ^ sender change value (subtract 'n' from current sender change value to get payment of value 'n') -> (HC.Hash256 -> HC.Signature) -- ^ signing function -> FullPayment -paymentFromState (CPaymentChannelState cp fti (CPaymentTxConfig changeAddr) _ _) = +paymentFromState (CPaymentChannelState _ cp fti (CPaymentTxConfig changeAddr) _ _ _) = createPayment cp fti changeAddr -- |Create payment, pure. @@ -114,7 +114,7 @@ -> (HC.Hash256 -> SendPubKey -> HC.Signature -> Bool) -> Payment -> Bool -verifyPaymentSigFromState (CPaymentChannelState cp fti (CPaymentTxConfig changeAddr) _ _) = +verifyPaymentSigFromState (CPaymentChannelState _ cp fti (CPaymentTxConfig changeAddr) _ _ _) = verifyPaymentSig cp fti changeAddr (cpSenderPubKey cp) ---Payment create/verify--- diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Refund.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Refund.hs --- a/src/Data/Bitcoin/PaymentChannel/Internal/Refund.hs +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Refund.hs @@ -11,7 +11,7 @@ import qualified Network.Haskoin.Script as HS getUnsignedRefundTx :: PaymentChannelState -> BitcoinAmount -> HT.Tx -getUnsignedRefundTx st txFee = -- @CPaymentChannelState = +getUnsignedRefundTx st txFee = let baseTx = toUnsignedBitcoinTx $ fromState st --create empty payment tx, which redeems funding tx refundOut = HT.TxOut @@ -34,7 +34,7 @@ PaymentChannelState -> BitcoinAmount -- ^Bitcoin transaction fee -> HC.Hash256 -getRefundTxHashForSigning pcs@(CPaymentChannelState cp _ _ _ _) newValueLeft = +getRefundTxHashForSigning pcs@(CPaymentChannelState _ cp _ _ _ _ _) newValueLeft = HS.txSigHash tx (getRedeemScript cp) 0 (HS.SigAll False) where tx = getUnsignedRefundTx pcs newValueLeft @@ -43,7 +43,7 @@ -> BitcoinAmount -- ^Bitcoin tx fee -> HC.Signature -- ^Signature over 'getUnsignedRefundTx' which verifies against clientPubKey -> FinalTx -refundTxAddSignature pcs@(CPaymentChannelState cp _ _ _ _) txFee clientRawSig = +refundTxAddSignature pcs@(CPaymentChannelState _ cp _ _ _ _ _) txFee clientRawSig = let inputScript = getP2SHInputScript cp $ refundTxScriptSig clientRawSig in diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/Serialization.hs b/src/Data/Bitcoin/PaymentChannel/Internal/Serialization.hs --- a/src/Data/Bitcoin/PaymentChannel/Internal/Serialization.hs +++ b/src/Data/Bitcoin/PaymentChannel/Internal/Serialization.hs @@ -22,7 +22,7 @@ import Data.Word (Word64) import Data.EitherR (fmapL) import Data.Typeable -import Debug.Trace +import qualified Data.Tagged as Tag -- Generic PayChanError instance instance Bin.Serialize PayChanError @@ -113,16 +113,16 @@ deriving instance Bin.Serialize RecvPubKey instance Bin.Serialize PaymentChannelState where - put (CPaymentChannelState par fti payConf valLeft sig) = - Bin.put par >> Bin.put fti >> Bin.put payConf >> + put (CPaymentChannelState cfg par fti payConf payCount valLeft sig) = + Bin.put cfg >> Bin.put par >> Bin.put fti >> Bin.put payConf >> Bin.put payCount >> Bin.put valLeft >> Bin.put sig get = CPaymentChannelState <$> Bin.get <*> Bin.get <*> - Bin.get <*> Bin.get <*> Bin.get + Bin.get <*> Bin.get <*> Bin.get <*> Bin.get <*> Bin.get instance Bin.Serialize ChannelParameters where - put (CChannelParameters pks pkr lt dustLimit) = - Bin.put pks >> Bin.put pkr >> Bin.put lt >> Bin.put dustLimit - get = CChannelParameters <$> Bin.get <*> Bin.get <*> Bin.get <*> Bin.get + put (CChannelParameters pks pkr lt) = + Bin.put pks >> Bin.put pkr >> Bin.put lt + get = CChannelParameters <$> Bin.get <*> Bin.get <*> Bin.get instance Bin.Serialize FundingTxInfo where put (CFundingTxInfo h idx val) = @@ -133,6 +133,11 @@ put (CPaymentTxConfig sendAddr) = Bin.put sendAddr get = CPaymentTxConfig <$> Bin.get + +instance Bin.Serialize Config where + put (Config dl sp) = + Bin.put dl >> Bin.put (Tag.unTagged sp) + get = Config <$> Bin.get <*> fmap Tag.Tagged Bin.get instance Bin.Serialize Payment where put (CPayment val sig) = 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 @@ -14,7 +14,7 @@ serverSigHash = HS.SigAll False csFromState :: PaymentChannelState -> ClientSignedPayment -csFromState cs@(CPaymentChannelState _ _ _ _ clientSig) = +csFromState cs@(CPaymentChannelState _ _ _ _ _ _ clientSig) = ClientSignedPayment (fromState cs) clientSig toUnsignedSettlementTx :: ClientSignedPayment -> HC.Address -> BitcoinAmount -> HT.Tx @@ -48,7 +48,7 @@ -> HC.Address -- ^Receiver destination address -> BitcoinAmount -- ^Bitcoin transaction fee -> HC.Hash256 -settlementSigningTxHashFromState cs@(CPaymentChannelState cp _ _ _ _) = +settlementSigningTxHashFromState cs@(CPaymentChannelState _ cp _ _ _ _ _) = getSettlementTxHashForSigning (csFromState cs) cp getSignedSettlementTx :: @@ -73,6 +73,6 @@ -> HC.Address -- ^Receiver/server funds destination address -> BitcoinAmount -- ^Bitcoin tx fee -> HT.Tx -signedSettlementTxFromState cs@(CPaymentChannelState cp _ _ _ _) signFunc recvAddr txFee = +signedSettlementTxFromState cs@(CPaymentChannelState _ cp _ _ _ _ _) signFunc recvAddr txFee = getSignedSettlementTx (csFromState cs) cp recvAddr txFee serverSig where serverSig = signFunc (settlementSigningTxHashFromState cs recvAddr txFee) diff --git a/src/Data/Bitcoin/PaymentChannel/Internal/State.hs b/src/Data/Bitcoin/PaymentChannel/Internal/State.hs --- a/src/Data/Bitcoin/PaymentChannel/Internal/State.hs +++ b/src/Data/Bitcoin/PaymentChannel/Internal/State.hs @@ -10,32 +10,34 @@ import qualified Network.Haskoin.Transaction as HT import qualified Network.Haskoin.Crypto as HC import qualified Network.Haskoin.Script as HS +import Data.Time.Clock + pcsChannelTotalValue = ftiOutValue . pcsFundingTxInfo pcsValueTransferred cs = pcsChannelTotalValue cs - pcsClientChangeVal cs pcsChannelValueLeft = pcsClientChangeVal pcsClientPubKey = cpSenderPubKey . pcsParameters pcsServerPubKey = cpReceiverPubKey . pcsParameters -pcsDustLimit = cpDustLimit . pcsParameters +pcsDustLimit = cDustLimit . pcsConfig pcsExpirationDate = cpLockTime . pcsParameters pcsClientChangeAddress = ptcSenderChangeAddress . pcsPaymentConfig pcsClientChangeScriptPubKey = addressToScriptPubKeyBS . pcsClientChangeAddress pcsLockTime = cpLockTime . pcsParameters -pcsPrevOut (CPaymentChannelState _ (CFundingTxInfo h i _) _ _ _) = OutPoint h i +pcsPrevOut (CPaymentChannelState _ _ (CFundingTxInfo h i _) _ _ _ _) = OutPoint h i -pcsChannelID :: PaymentChannelState -> HT.OutPoint -pcsChannelID pcs = HT.OutPoint (ftiHash fti) (ftiOutIndex fti) +pcsChannelFundingSource :: PaymentChannelState -> HT.OutPoint +pcsChannelFundingSource pcs = HT.OutPoint (ftiHash fti) (ftiOutIndex fti) where fti = pcsFundingTxInfo pcs pcsGetPayment :: PaymentChannelState -> Payment -pcsGetPayment (CPaymentChannelState _ _ _ val sig) = CPayment val sig +pcsGetPayment (CPaymentChannelState _ _ _ _ _ val sig) = CPayment val sig -- |Set new client/sender change address. -- Use this function if the client wishes to change its change address. -- 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 = +setClientChangeAddress pcs@(CPaymentChannelState _ _ _ pConf _ _ _) addr = pcs { pcsPaymentConfig = newPayConf } where newPayConf = pConf { ptcSenderChangeAddress = addr } @@ -47,7 +49,7 @@ -- This avoids creating a Bitcoin transaction that won't circulate -- in the Bitcoin P2P network. channelValueLeft :: PaymentChannelState -> BitcoinAmount -channelValueLeft pcs@(CPaymentChannelState (CChannelParameters _ _ _ dustLimit) _ _ _ _) = +channelValueLeft pcs@(CPaymentChannelState (Config dustLimit _) _ _ _ _ _ _) = pcsClientChangeVal pcs - dustLimit -- |Returns 'True' if all available channel value has been transferred, 'False' otherwise @@ -56,22 +58,25 @@ psSigHash (pcsPaymentSignature pcs) == HS.SigNone True || channelValueLeft pcs == 0 -newPaymentChannelState channelParameters fundingTxInfo paymentConfig paySig = +newPaymentChannelState cfg channelParameters fundingTxInfo paymentConfig paySig = CPaymentChannelState { + pcsConfig = cfg, pcsParameters = channelParameters, pcsFundingTxInfo = fundingTxInfo, pcsPaymentConfig = paymentConfig, - pcsClientChangeVal = ftiOutValue fundingTxInfo, + pcsPaymentCount = 0, + pcsClientChangeVal = ftiOutValue fundingTxInfo, pcsPaymentSignature = paySig } + -- |Update state with verified payment. updatePaymentChannelState :: PaymentChannelState -> FullPayment -> Either PayChanError PaymentChannelState -updatePaymentChannelState (CPaymentChannelState cp fun@(CFundingTxInfo h i _) - pconf@(CPaymentTxConfig addr) oldSenderVal _) +updatePaymentChannelState (CPaymentChannelState cfg cp fun@(CFundingTxInfo h i _) + pconf@(CPaymentTxConfig addr) payCount oldSenderVal _) (CFullPayment payment@(CPayment newSenderVal _) payOP payScript payChgAddr) | (HT.outPointHash payOP /= h) || (HT.outPointIndex payOP /= i) = Left $ OutPointMismatch $ OutPoint h i @@ -79,13 +84,24 @@ Left $ ChangeAddrMismatch addr | payScript /= getRedeemScript cp = Left $ RedeemScriptMismatch $ getRedeemScript cp - | newSenderVal <= oldSenderVal = - CPaymentChannelState cp fun pconf newSenderVal . cpSignature <$> - checkDustLimit cp payment - | otherwise = Left $ BadPaymentValue (newSenderVal - oldSenderVal) + | newSenderVal > oldSenderVal = + Left $ BadPaymentValue (newSenderVal - oldSenderVal) + | otherwise = + CPaymentChannelState cfg cp fun pconf (payCount+1) newSenderVal . cpSignature <$> + checkDustLimit cfg payment -checkDustLimit :: ChannelParameters -> Payment -> Either PayChanError Payment -checkDustLimit (CChannelParameters _ _ _ dustLimit) payment@(CPayment senderChangeVal _) +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 currentTime (Config _ settlePeriodHrs) (CChannelParameters _ _ (LockTimeDate expTime)) = + currentTime > (settlePeriod `addUTCTime` expTime) + where settlePeriod = -1 * fromIntegral (toSeconds settlePeriodHrs) :: NominalDiffTime +isPastLockTimeDate _ _ (CChannelParameters _ _ (LockTimeBlockHeight _)) = + True + -- We don't have the current Bitcoin block so we regard the channel as expired, + -- in order to make we don't accept block count-based locktimes for now. + 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric, DataKinds #-} module Data.Bitcoin.PaymentChannel.Internal.Types ( @@ -24,21 +24,27 @@ import qualified Network.Haskoin.Script as HS import Data.Typeable import Data.Word -import GHC.Generics +import qualified Data.Tagged as Tag + +defaultConfig = Config defaultDustLimit defaultSettlementPeriod + defaultDustLimit = 700 :: BitcoinAmount -defaultMinChanSize = defaultDustLimit * 2 +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 + pcsConfig :: Config, -- |Defined by the sender and receiver pcsParameters :: ChannelParameters, -- |Retrieved by looking at the in-blockchain funding transaction pcsFundingTxInfo :: FundingTxInfo, pcsPaymentConfig :: PaymentTxConfig, + pcsPaymentCount :: Word64, -- |Client change value pcsClientChangeVal :: BitcoinAmount, -- |Signature over payment transaction of value 'pcsValueLeft' @@ -50,13 +56,7 @@ cpSenderPubKey :: SendPubKey, cpReceiverPubKey :: RecvPubKey, -- |Channel expiration date/time - cpLockTime :: BitcoinLockTime, - -- |Use a per-channel dust limit, such that when the remaining channel value - -- hits this limit (rather than zero), we say the channel is exhausted. - -- This avoids the relatively complex SigSingle/SigNone logic, and reduces - -- a payment to just a ANYONECANPAY|SigSingle signature with a corresponding - -- change output, which is set to the channel funding address. - cpDustLimit :: BitcoinAmount + cpLockTime :: BitcoinLockTime } deriving (Eq, Show, Typeable) -- |Holds information about the Bitcoin transaction used to fund @@ -73,7 +73,17 @@ ptcSenderChangeAddress :: HC.Address } deriving (Eq, Show, Typeable) --- |Used to transfer value from sender to receiver. +-- |Miscellaneous configuration options +data Config = Config { + -- | Refuse to accept/produce payments with a client change value less than this amount. + cDustLimit :: BitcoinAmount + -- | This many hours before the channel expiration date, consider the channel closed. + -- This gives the receiver time to publish the settlement transaction, before the + -- refund transaction becomes valid. + , cSettlementPeriod :: Hour +} deriving (Eq, Show, Typeable) + +-- |Contains the bare minimum of information to transfer value from sender to receiver. data Payment = CPayment { -- |Channel value remaining ('pcsValueLeft' of the state from which this payment was made) cpClientChange :: BitcoinAmount @@ -94,18 +104,14 @@ -- |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. + -- |SigHash flag. Always "SigSingle True". ,psSigHash :: HS.SigHash } deriving (Eq, Show, Typeable) -- |Wraps a Network.Haskoin.Script.Script newtype ChanScript = ChanScript { getScript :: HS.Script } deriving (Eq, Show) --- Never confuse sender/receiver pubkey again: let compiler check +-- Never confuse sender/receiver pubkey newtype SendPubKey = MkSendPubKey { getSenderPK :: HC.PubKey } deriving (Eq, Show) @@ -121,3 +127,7 @@ getPubKey = getSenderPK instance IsPubKey RecvPubKey where getPubKey = getReceiverPK + +type Hour = Tag.Tagged "Hour" Word32 +toSeconds :: Hour -> Integer +toSeconds = fromIntegral . (* 3600) . Tag.unTagged diff --git a/src/Data/Bitcoin/PaymentChannel/Movable.hs b/src/Data/Bitcoin/PaymentChannel/Movable.hs deleted file mode 100644 --- a/src/Data/Bitcoin/PaymentChannel/Movable.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-| -Module : Data.Bitcoin.PaymentChannel.Movable -Description : Bitcoin payment channel library -License : PublicDomain -Maintainer : runesvend@gmail.com -Stability : experimental -Portability : POSIX - -TODO --} - -module Data.Bitcoin.PaymentChannel.Movable where - -import Data.Bitcoin.PaymentChannel -import Data.Bitcoin.PaymentChannel.Types -import Data.Bitcoin.PaymentChannel.Internal.Types -import qualified Data.Bitcoin.PaymentChannel.Internal.State as S -import qualified Network.Haskoin.Crypto as HC -import qualified Data.Serialize as Bin -import Control.Applicative ((<|>)) - --- |A ReceiverPaymentChannel whose received value can be redeemed while --- keeping the channel open, by switching between two different OutPoints --- in the FundingTxInfo. -data MovableChan = - Settled { - beginVal :: BitcoinAmount - , beginState :: ReceiverPaymentChannel - } | Unsettled { - channels :: ChannelPair - -- If payment 1/2 has been accepted, accept 2/2 with 'receiveSecondPayment pp' - , finishPay :: Maybe PartialPayment - } -- deriving (Show) - -data ChannelPair = ChannelPair { - beginVal' :: BitcoinAmount - , oldState :: ReceiverPaymentChannel - , newState :: ReceiverPaymentChannel -} - --- |We wrap the state in which only payment 1/2 has been received in a data --- type, in order to be able to serialize it to disk. -data PartialPayment = - NewNeedsUpdate ChannelPair BitcoinAmount - | OldNeedsUpdate ChannelPair BitcoinAmount - -instance PaymentChannel MovableChan where - valueToMe = channelValueLeft . fst . getStateForClosing - getChannelState = rpcState . fst . getStateForClosing - _setChannelState (Settled v rpc) s = Settled v (rpc { rpcState = s }) - _setChannelState (Unsettled (ChannelPair v old new) fp) s = - Unsettled (ChannelPair v (setState s old) (setState s new)) fp - where setState s rpc = rpc { rpcState = s } - -newMovableChan :: - ChannelParameters - -> FundingTxInfo - -> FullPayment - -> Either PayChanError (BitcoinAmount, MovableChan, BitcoinAmount) -newMovableChan cp fti@(CFundingTxInfo _ _ chanVal) - fullPayment@(CFullPayment _ _ _ payChgAddr) = - checkChangeAddr >>= channelFromInitialPayment cp fti desiredChangeAddr >>= - \(payAmount, rpc) -> Right (payAmount, Settled chanVal rpc, channelValueLeft rpc) - where desiredChangeAddr = getFundingAddress cp - checkChangeAddr = - if payChgAddr /= desiredChangeAddr then - Left $ ChangeAddrMismatch desiredChangeAddr - else - Right fullPayment - -getStateForClosing :: MovableChan -> (ReceiverPaymentChannel,BitcoinAmount) -getStateForClosing (Settled v rpc) = (rpc,v) -getStateForClosing (Unsettled (ChannelPair v _ newRpc) _) = (newRpc,v) - -getStateByInfo :: MovableChan -> BitcoinLockTime -> OutPoint -> Maybe (ReceiverPaymentChannel,BitcoinAmount) -getStateByInfo mc lt op = case mc of - (Settled v rpc) -> checkInfo rpc v - (Unsettled (ChannelPair v old new) _) -> checkInfo new v <|> checkInfo old v - where checkInfo rpc v = - if getChannelID rpc == op && - getExpirationDate rpc == lt then - Just (rpc,v) - else - Nothing - -moveChannel :: - MovableChan - -> (HC.Hash256 -> HC.Signature) -- ^ Function which produces a signature which verifies against 'cpReceiverPubKey' - -> HC.Address -- ^ Receiver destination address. Funds sent over the channel will be sent to this address, the rest back to the client change address (an argument to 'channelWithInitialPaymentOf'). - -> BitcoinAmount -- ^ Bitcoin transaction fee - -> Maybe (Tx, MovableChan) -moveChannel Unsettled{} _ _ _ = Nothing -moveChannel (Settled v rpc) signFunc destAddr txFee = - -- If we haven't received any value, moving the channel makes no sense - if valueToMe rpc > 0 then - Just (settleTx, Unsettled (ChannelPair v rpc newRpc) Nothing) - else - Nothing - where settleTx = getSettlementBitcoinTx rpc signFunc destAddr txFee - newRpc = CReceiverPaymentChannel $ S.setFundingSource (getChannelState rpc) fti - fti = CFundingTxInfo (txHash settleTx) - -- Client output always at index zero - 0 (senderChangeValue rpc) - -markAsSettled :: - MovableChan - -> Maybe MovableChan -markAsSettled Settled{} = Nothing -markAsSettled (Unsettled _ (Just _)) = Nothing -markAsSettled (Unsettled (ChannelPair v _ newRpc) Nothing) = - if valueToMe newRpc > 0 then - Just $ Settled v newRpc - else - Nothing - -recvSinglePayment :: - MovableChan - -> FullPayment - -> Either PayChanError (BitcoinAmount, MovableChan, BitcoinAmount) -recvSinglePayment (Settled v rpc) fp = recvPayment rpc fp >>= - \(a, newRpc) -> Right (a, Settled v newRpc, channelValueLeft newRpc) --- Accept payment 1/2 -recvSinglePayment (Unsettled cp@(ChannelPair _ old new) Nothing) fp@(CFullPayment _ op _ _) - | S.pcsPrevOut (getChannelState old) == op = oldRecvPay cp fp - | S.pcsPrevOut (getChannelState new) == op = newRecvPay cp fp - | otherwise = Left . OutPointMismatch . S.pcsPrevOut . getChannelState $ new --- If we've already received paymed 1/2, we receive 2/2 with this -recvSinglePayment (Unsettled _ (Just pp)) fp = receiveSecondPayment pp fp - -oldRecvPay :: - ChannelPair - -> FullPayment - -> Either PayChanError (BitcoinAmount, MovableChan, BitcoinAmount) -oldRecvPay (ChannelPair v old new) fp = recvPayment old fp >>= - -- Update old state, and leave behind a function that updates the new state - \(amt, newOld) -> Right - (amt, Unsettled (ChannelPair v newOld new) - (Just $ NewNeedsUpdate (ChannelPair v newOld new) amt), - channelValueLeft newOld) - -newRecvPay :: - ChannelPair - -> FullPayment - -> Either PayChanError (BitcoinAmount, MovableChan, BitcoinAmount) -newRecvPay (ChannelPair v old new) fp = recvPayment new fp >>= - -- Update new state, and leave behind a function that updates the old state - \(amt, newNew) -> Right - (amt, Unsettled (ChannelPair v old newNew) - (Just $ OldNeedsUpdate (ChannelPair v old newNew) amt), - channelValueLeft newNew) - -receiveSecondPayment :: - PartialPayment - -> FullPayment - -> Either PayChanError (BitcoinAmount, MovableChan, BitcoinAmount) -receiveSecondPayment (OldNeedsUpdate cp amt) fp = - checkChangeValueMatch amt fp >>= oldRecvPay cp >>= - \(amt, mc, vLeft) -> Right (amt, mc { finishPay = Nothing }, vLeft) -receiveSecondPayment (NewNeedsUpdate cp amt) fp = - checkChangeValueMatch amt fp >>= newRecvPay cp >>= - \(amt, mc, vLeft) -> Right (amt, mc { finishPay = Nothing }, vLeft) - --- | We want to make sure that payment 1/2 and 2/2 are of equal value -checkChangeValueMatch :: BitcoinAmount -> FullPayment -> Either PayChanError FullPayment -checkChangeValueMatch firstPayVal fp@(CFullPayment (CPayment val _) _ _ _) = - if val /= firstPayVal then Left $ PartialPaymentBadValue firstPayVal else Right fp - - -instance Bin.Serialize MovableChan where - put (Settled bVal rpc) = - Bin.putWord8 0x01 >> Bin.put bVal >> Bin.put rpc - put (Unsettled cPair mPP) = - Bin.putWord8 0x02 >> Bin.put cPair >> Bin.put mPP - get = Bin.getWord8 >>= \w -> case w of - 0x01 -> Settled <$> Bin.get <*> Bin.get - 0x02 -> Unsettled <$> Bin.get <*> Bin.get - n -> fail $ "unknown start byte: " ++ show n - -instance Bin.Serialize ChannelPair where - put (ChannelPair bVal old new) = - Bin.put bVal >> Bin.put old >> Bin.put new - get = ChannelPair <$> Bin.get <*> Bin.get <*> Bin.get - -instance Bin.Serialize PartialPayment where - put (NewNeedsUpdate cp amt) = Bin.putWord8 0x01 >> Bin.put cp >> Bin.put amt - put (OldNeedsUpdate cp amt) = Bin.putWord8 0x02 >> Bin.put cp >> Bin.put amt - get = Bin.getWord8 >>= \w -> case w of - 0x01 -> NewNeedsUpdate <$> Bin.get <*> Bin.get - 0x02 -> OldNeedsUpdate <$> Bin.get <*> Bin.get - n -> fail $ "unknown start byte: " ++ show n 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 @@ -12,50 +12,49 @@ module Data.Bitcoin.PaymentChannel.Types ( -PaymentChannel(..), -SenderPaymentChannel(..), -ReceiverPaymentChannel(..), -Payment,cpSignature, -FullPayment(..), -FundingTxInfo(..), -ChannelParameters(..), -PayChanError(..), -PaymentChannelState, -SendPubKey(..),RecvPubKey(..),IsPubKey(..), -BitcoinAmount, -BitcoinLockTime(..), fromDate, -usesBlockHeight, - --- Util -b64Encode, --- Constants -defaultDustLimit, + PaymentChannel(..), + SenderPaymentChannel(..), + ReceiverPaymentChannel(..), + Config(..),defaultConfig, + Payment,cpSignature, + FullPayment(..), + FundingTxInfo(..), + ChannelParameters(..), + PayChanError(..), + PaymentChannelState, + SendPubKey(..),RecvPubKey(..),IsPubKey(..), + BitcoinAmount, + BitcoinLockTime(..), fromDate, + usesBlockHeight ) where import Data.Bitcoin.PaymentChannel.Internal.Types -import Data.Bitcoin.PaymentChannel.Internal.Serialization +import Data.Bitcoin.PaymentChannel.Internal.Serialization () 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 qualified Data.Serialize as Bin import Data.Aeson as JSON -- (FromJSON, ToJSON) import qualified Network.Haskoin.Crypto as HC import qualified Network.Haskoin.Transaction as HT --- import qualified Network.Haskoin.Transaction as HS +import Data.Word (Word64) -- |Get various information about an open payment channel. class PaymentChannel a where - -- |Get value sent to receiver/left for sender + -- |Get amount received by receiver/left for sender valueToMe :: a -> BitcoinAmount -- |Retrieve internal state object getChannelState :: a -> PaymentChannelState - - getChannelID :: a -> HT.OutPoint + getChannelFunding :: a -> HT.OutPoint getExpirationDate :: a -> BitcoinLockTime getSenderPubKey :: a -> SendPubKey + getFundingAmount :: a -> BitcoinAmount + getPaymentCount :: a -> Word64 + fundingAddress :: a -> HC.Address getNewestPayment :: a -> Payment getNewestSig :: a -> HC.Signature -- |Return True if channel expires earlier than given expiration date @@ -68,9 +67,12 @@ -- |Returns 'True' if all available channel value has been transferred, 'False' otherwise channelIsExhausted :: a -> Bool - getChannelID = S.pcsChannelID . getChannelState + getChannelFunding = S.pcsChannelFundingSource . getChannelState getExpirationDate = S.pcsExpirationDate . getChannelState getSenderPubKey = S.pcsClientPubKey . getChannelState + getFundingAmount = S.pcsChannelTotalValue . getChannelState + getPaymentCount = pcsPaymentCount . getChannelState + fundingAddress = Script.getP2SHFundingAddress . pcsParameters . getChannelState senderChangeValue = pcsClientChangeVal . getChannelState channelValueLeft = S.channelValueLeft . getChannelState channelIsExhausted = S.channelIsExhausted . getChannelState diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -17,16 +17,120 @@ import qualified Data.Serialize as Bin import Data.Typeable +import Data.Time.Clock (UTCTime(..)) +import Data.Time.Calendar (Day(..)) + import Test.QuickCheck -import Debug.Trace +import Test.Framework (Test, testGroup, defaultMain) +import Test.Framework.Providers.QuickCheck2 (testProperty) -dUST_LIMIT = 700 :: BitcoinAmount -mIN_CHANNEL_SIZE = 1400 :: BitcoinAmount +-- |We don't bother testing timestamps for now +nowishTimestamp :: UTCTime +nowishTimestamp = UTCTime (ModifiedJulianDay 57683) 0 -- 2016-10-22 -testAddrTestnet = "2N414xMNQaiaHCT5D7JamPz7hJEc9RG7469" :: HC.Address -testAddrLivenet = "14wjVnwHwMAXDr6h5Fw38shCWUB6RSEa63" :: HC.Address +mIN_CHANNEL_SIZE :: BitcoinAmount +mIN_CHANNEL_SIZE = cDustLimit defaultConfig * 2 +testAddrTestnet :: HC.Address +testAddrTestnet = "2N414xMNQaiaHCT5D7JamPz7hJEc9RG7469" +testAddrLivenet :: HC.Address +testAddrLivenet = "14wjVnwHwMAXDr6h5Fw38shCWUB6RSEa63" + +main :: IO () +main = defaultMain tests + +tests :: [Test] +tests = + [ testGroup "Payment" + [ testProperty "Sender value in settlement tx" $ + testPaymentSession checkSenderValue + , testProperty "Receiver value in settlement tx" $ + testPaymentSession checkReceiverValue + , testProperty "Sender/receiver state match" $ + testPaymentSession checkSendRecvStateMatch + , testProperty "Sent amount == received amount" $ + 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 + ] + ] + +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 clientChangeAmount = HT.outValue . head . HT.txOut $ settleTx + -- Check that the client change amount in the settlement transaction equals the + -- channel funding amount minus the sum of all payment amounts. + let fundAmountMinusPaySum = S.pcsChannelTotalValue (getChannelState recvChan) - + fromIntegral (sum amountSent) + fromIntegral clientChangeAmount == fundAmountMinusPaySum + +checkReceiverValue :: (ArbChannelPair, [BitcoinAmount]) -> Bool +checkReceiverValue (ArbChannelPair _ recvChan amountSent _ recvSignFunc, _) = do + let settleTx = getSettlementBitcoinTx recvChan recvSignFunc testAddrLivenet 0 + let receiverAmount = HT.outValue (HT.txOut settleTx !! 1) + -- Check receiver amount in settlement transaction with zero fee equals sum + -- of all payments. + (fromIntegral receiverAmount :: BitcoinAmount) == fromIntegral (sum amountSent) + +checkSendRecvStateMatch :: (ArbChannelPair, [BitcoinAmount]) -> Bool +checkSendRecvStateMatch (ArbChannelPair sendChan recvChan _ _ _, _) = + getChannelState sendChan == getChannelState recvChan + +checkRecvSendAmount :: (ArbChannelPair, [BitcoinAmount]) -> Bool +checkRecvSendAmount (ArbChannelPair _ _ amountSent amountRecvd _, _) = + amountSent == amountRecvd + +testPaymentSession :: + ((ArbChannelPair, [BitcoinAmount]) -> Bool) + -> ArbChannelPair + -> [BitcoinAmount] + -> Bool +testPaymentSession testFunc arbChanPair paymentAmountList = + testFunc (runChanPair arbChanPair paymentAmountList) + +runChanPair :: ArbChannelPair -> [BitcoinAmount] -> (ArbChannelPair, [BitcoinAmount]) +runChanPair chanPair paymentAmountList = + (foldl doPayment chanPair paymentAmountList, paymentAmountList) + +jsonSerDeser :: (Show a, Eq a, JSON.FromJSON a, JSON.ToJSON a) => a -> Bool +jsonSerDeser fp = + maybe False checkEquals decodedObj + where json = JSON.encode fp + decodedObj = JSON.decode json + checkEquals serDeserVal = + if serDeserVal /= fp then + error ("Ser/deser mismatch.\nOriginal: " ++ show fp ++ "\nCopy: " ++ show decodedObj) + else + True + +binSerDeser :: (Typeable a, Show a, Eq a, Bin.Serialize a) => a -> Bool +binSerDeser fp = + checkEquals decodeRes + where bs = Bin.encode fp + decodeRes = deserEither bs + checkEquals serDeserRes = case serDeserRes of + Left e -> error $ "Serialize/deserialize error: " ++ show e + Right res -> if res /= fp then + error ("Ser/deser mismatch.\nOriginal: " ++ show fp ++ "\nCopy: " ++ show res) + else + True + + + + data ArbChannelPair = ArbChannelPair SenderPaymentChannel ReceiverPaymentChannel [BitcoinAmount] [BitcoinAmount] (HC.Hash256 -> HC.Signature) @@ -39,7 +143,7 @@ doPayment (ArbChannelPair spc rpc sendList recvList f) amount = let (amountSent, pmn, newSpc) = sendPayment spc amount - eitherRpc = recvPayment rpc pmn + eitherRpc = recvPayment nowishTimestamp rpc pmn in case eitherRpc of Left e -> error (show e) @@ -69,10 +173,10 @@ ArbitraryPubKey sendPriv sendPK <- arbitrary -- receiver key pair ArbitraryPubKey recvPriv recvPK <- arbitrary - -- expiration date - lockTime <- 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 dUST_LIMIT, + (MkSendPubKey sendPK) (MkRecvPubKey recvPK) lockTime, (sendPriv, recvPriv)) mkChanPair :: Gen (ArbChannelPair, FullPayment) @@ -80,12 +184,11 @@ (cp, (sendPriv, recvPriv)) <- mkChanParams fti <- arbitrary -- value of first payment - initPayAmount <- arbitrary -- fromIntegral <$> choose (0, chanAmount) + initPayAmount <- arbitrary -- create states - let (initPayActualAmount,paymnt,sendChan) = channelWithInitialPaymentOf + let (initPayActualAmount,paymnt,sendChan) = channelWithInitialPaymentOf defaultConfig cp fti (flip HC.signMsg sendPriv) (getFundingAddress cp) initPayAmount - let eitherRecvChan = channelFromInitialPayment - cp fti (getFundingAddress cp) paymnt + let eitherRecvChan = channelFromInitialPayment nowishTimestamp defaultConfig cp fti paymnt case eitherRecvChan of Left e -> error (show e) Right (initRecvAmount,recvChan) -> return @@ -94,9 +197,6 @@ (flip HC.signMsg recvPriv), paymnt) -instance Arbitrary BitcoinLockTime where - arbitrary = fmap parseBitcoinLocktime arbitrary - instance Arbitrary FundingTxInfo where arbitrary = do ArbitraryTxHash h <- arbitrary @@ -108,72 +208,3 @@ instance Arbitrary BitcoinAmount where arbitrary = fromIntegral <$> choose (0, round $ 21e6 * 1e8 :: Integer) - -runChanPair :: ArbChannelPair -> [BitcoinAmount] -> (ArbChannelPair, [BitcoinAmount]) -runChanPair chanPair paymentAmountList = - (foldl doPayment chanPair paymentAmountList, paymentAmountList) - -checkChanPair :: (ArbChannelPair, [BitcoinAmount]) -> Bool -checkChanPair (ArbChannelPair sendChan recvChan amountSent amountRecvd recvSignFunc, _) = do - let settleTx = getSettlementBitcoinTx recvChan recvSignFunc testAddrLivenet 0 - let clientChangeAmount = HT.outValue . head . HT.txOut $ settleTx - -- Check that the client change amount in the settlement transaction equals the - -- channel funding amount minus the sum of all payment amounts. - let fundAmountMinusPaySum = S.pcsChannelTotalValue (getChannelState recvChan) - - fromIntegral (sum amountSent) - let clientValueIsGood = fromIntegral clientChangeAmount == fundAmountMinusPaySum :: Bool - -- Debug print - let checkGoodClientValue goodCV = if not goodCV then - error $ "Bad client change value. Actual: " ++ show clientChangeAmount ++ - " should be " ++ show fundAmountMinusPaySum - else - goodCV - -- Check that sender/receiver (client/server) agree on channel state - let statesMatch = getChannelState recvChan == getChannelState sendChan - -- Send/recv value lists match - let recvSendAmountMatch = amountSent == amountRecvd - checkGoodClientValue clientValueIsGood && statesMatch && recvSendAmountMatch - - - -jsonSerDeser :: (Show a, Eq a, JSON.FromJSON a, JSON.ToJSON a) => a -> Bool -jsonSerDeser fp = - maybe False checkEquals decodedObj - where json = JSON.encode fp - decodedObj = JSON.decode json - checkEquals serDeserVal = - if serDeserVal /= fp then - error ("Ser/deser mismatch.\nOriginal: " ++ show fp ++ "\nCopy: " ++ show decodedObj) - else - True - -binSerDeser :: (Typeable a, Show a, Eq a, Bin.Serialize a) => a -> Bool -binSerDeser fp = - checkEquals decodeRes - where bs = Bin.encode fp - decodeRes = deserEither bs - checkEquals serDeserRes = case serDeserRes of - Left e -> error $ "Serialize/deserialize error: " ++ show e - Right res -> if res /= fp then - error ("Ser/deser mismatch.\nOriginal: " ++ show fp ++ "\nCopy: " ++ show res) - else - True - -testPaymentSession :: ArbChannelPair -> [BitcoinAmount] -> Bool -testPaymentSession arbChanPair paymentAmountList = - checkChanPair (runChanPair arbChanPair paymentAmountList) - -testPaymentJSON = jsonSerDeser :: FullPayment -> Bool -testPaymentBin = binSerDeser :: FullPayment -> Bool -testScriptBin = binSerDeser :: ChanScript -> Bool - -main :: IO () -main = do - quickCheckWith stdArgs testPaymentSession - quickCheckWith stdArgs testPaymentJSON - quickCheckWith stdArgs testPaymentBin --- quickCheckWith stdArgs testScriptBin - - - -