diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,119 @@ + CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT + PROVIDE LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT + CREATE AN ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES + THIS INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO + WARRANTIES REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION + OR WORKS PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES + RESULTING FROM THE USE OF THIS DOCUMENT OR THE INFORMATION OR + WORKS PROVIDED HEREUNDER. + +Statement of Purpose + +The laws of most jurisdictions throughout the world automatically +confer exclusive Copyright and Related Rights (defined below) upon the +creator and subsequent owner(s) (each and all, an "owner") of an +original work of authorship and/or a database (each, a "Work"). + +Certain owners wish to permanently relinquish those rights to a Work +for the purpose of contributing to a commons of creative, cultural and +scientific works ("Commons") that the public can reliably and without +fear of later claims of infringement build upon, modify, incorporate +in other works, reuse and redistribute as freely as possible in any +form whatsoever and for any purposes, including without limitation +commercial purposes. These owners may contribute to the Commons to +promote the ideal of a free culture and the further production of +creative, cultural and scientific works, or to gain reputation or +greater distribution for their Work in part through the use and +efforts of others. + +For these and/or other purposes and motivations, and without any +expectation of additional consideration or compensation, the person +associating CC0 with a Work (the "Affirmer"), to the extent that he or +she is an owner of Copyright and Related Rights in the Work, +voluntarily elects to apply CC0 to the Work and publicly distribute +the Work under its terms, with knowledge of his or her Copyright and +Related Rights in the Work and the meaning and intended legal effect +of CC0 on those rights. + +1. Copyright and Related Rights. A Work made available under CC0 may +be protected by copyright and related or neighboring rights +("Copyright and Related Rights"). Copyright and Related Rights +include, but are not limited to, the following: + + the right to reproduce, adapt, distribute, perform, display, + communicate, and translate a Work; moral rights retained by the + original author(s) and/or performer(s); publicity and privacy + rights pertaining to a person's image or likeness depicted in a + Work; rights protecting against unfair competition in regards to a + Work, subject to the limitations in paragraph 4(a), below; rights + protecting the extraction, dissemination, use and reuse of data in + a Work; database rights (such as those arising under Directive + 96/9/EC of the European Parliament and of the Council of 11 March + 1996 on the legal protection of databases, and under any national + implementation thereof, including any amended or successor version + of such directive); and other similar, equivalent or corresponding + rights throughout the world based on applicable law or treaty, and + any national implementations thereof. + +2. Waiver. To the greatest extent permitted by, but not in +contravention of, applicable law, Affirmer hereby overtly, fully, +permanently, irrevocably and unconditionally waives, abandons, and +surrenders all of Affirmer's Copyright and Related Rights and +associated claims and causes of action, whether now known or unknown +(including existing as well as future claims and causes of action), in +the Work (i) in all territories worldwide, (ii) for the maximum +duration provided by applicable law or treaty (including future time +extensions), (iii) in any current or future medium and for any number +of copies, and (iv) for any purpose whatsoever, including without +limitation commercial, advertising or promotional purposes (the +"Waiver"). Affirmer makes the Waiver for the benefit of each member of +the public at large and to the detriment of Affirmer's heirs and +successors, fully intending that such Waiver shall not be subject to +revocation, rescission, cancellation, termination, or any other legal +or equitable action to disrupt the quiet enjoyment of the Work by the +public as contemplated by Affirmer's express Statement of Purpose. + +3. Public License Fallback. Should any part of the Waiver for any +reason be judged legally invalid or ineffective under applicable law, +then the Waiver shall be preserved to the maximum extent permitted +taking into account Affirmer's express Statement of Purpose. In +addition, to the extent the Waiver is so judged Affirmer hereby grants +to each affected person a royalty-free, non transferable, non +sublicensable, non exclusive, irrevocable and unconditional license to +exercise Affirmer's Copyright and Related Rights in the Work (i) in +all territories worldwide, (ii) for the maximum duration provided by +applicable law or treaty (including future time extensions), (iii) in +any current or future medium and for any number of copies, and (iv) +for any purpose whatsoever, including without limitation commercial, +advertising or promotional purposes (the "License"). The License shall +be deemed effective as of the date CC0 was applied by Affirmer to the +Work. Should any part of the License for any reason be judged legally +invalid or ineffective under applicable law, such partial invalidity +or ineffectiveness shall not invalidate the remainder of the License, +and in such case Affirmer hereby affirms that he or she will not (i) +exercise any of his or her remaining Copyright and Related Rights in +the Work or (ii) assert any associated claims and causes of action +with respect to the Work, in either case contrary to Affirmer's +express Statement of Purpose. + +4. Limitations and Disclaimers. + + No trademark or patent rights held by Affirmer are waived, + abandoned, surrendered, licensed or otherwise affected by this + document. Affirmer offers the Work as-is and makes no + representations or warranties of any kind concerning the Work, + express, implied, statutory or otherwise, including without + limitation warranties of title, merchantability, fitness for a + particular purpose, non infringement, or the absence of latent or + other defects, accuracy, or the present or absence of errors, + whether or not discoverable, all to the greatest extent + permissible under applicable law. Affirmer disclaims + responsibility for clearing rights of other persons that may apply + to the Work or any use thereof, including without limitation any + person's Copyright and Related Rights in the Work. Further, + Affirmer disclaims responsibility for obtaining any necessary + consents, permissions or other rights required for any use of the + Work. Affirmer understands and acknowledges that Creative Commons + is not a party to this document and has no duty or obligation with + respect to this CC0 or use of the Work. + diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE CPP #-} +module Main where + +import qualified PaymentChannel.Test as Pay +import Criterion.Main +import Test.QuickCheck (sample') + +import qualified Data.ByteString as B +#if !MIN_VERSION_bytestring(0,10,0) +instance NFData B.ByteString +#endif + +payCount = 1000 :: Integer + +main :: IO () +main = do + (arbPair,_) <- fmap head $ sample' $ Pay.mkChanPairInitAmount 0 + let mkPayment = Pay.createPayment (Pay.sendChan arbPair) + (_,payment) <- either (fail . show) return =<< mkPayment 1 + let multiMkVerify = Pay.runChanPair arbPair (fromIntegral <$> [1..payCount]) + defaultMain + [ bench "Create payment" $ nfIO ( either (error . show) id <$> mkPayment 2 ) + , bench "Verify payment" $ nfIO + ( either (error . show) id <$> Pay.acceptPayment (Pay.recvChan arbPair) payment ) + , bench (show payCount ++ " rounds of create+verify payment") $ nfIO multiMkVerify + ] diff --git a/bitcoin-payment-channel.cabal b/bitcoin-payment-channel.cabal --- a/bitcoin-payment-channel.cabal +++ b/bitcoin-payment-channel.cabal @@ -1,9 +1,9 @@ --- This file has been generated from package.yaml by hpack version 0.14.0. +-- This file has been generated from package.yaml by hpack version 0.15.0. -- -- see: https://github.com/sol/hpack name: bitcoin-payment-channel -version: 1.0.0.0 +version: 1.0.1.0 synopsis: Instant, two-party Bitcoin payments description: A Bitcoin payment channel allows secure and instant transfer of bitcoins from one party to another. Payments are created and verified in less than a millisecond (plus network latency), and cannot be double spent, as the receiver of funds is defined during channel setup. When the channel is closed, the settlement transaction transfers the appropriate value to each party, thus paying the Bitcoin transaction fee only once, regardless of the number of payments made over the channel. The channel setup procedure is trustless, because the funding party - after the chosen expiration date - is able to reclaim the bitcoins used to fund the channel, in case the receiving party goes missing. @@ -14,7 +14,8 @@ bug-reports: https://github.com/runeksvendsen/bitcoin-payment-channel/issues author: Rune K. Svendsen maintainer: Rune K. Svendsen -license: PublicDomain +license: OtherLicense +license-file: LICENSE build-type: Simple cabal-version: >= 1.10 @@ -30,7 +31,7 @@ build-depends: base >=4.7 && <5 , haskoin-core >=0.4.0 && <0.5.0 - , haskell-rbpcp-api + , rbpcp-api , base16-bytestring >=0.1.0 && <0.2.0 , bytestring >=0.10.0 && <0.11.0 , cereal >=0.5.0 && <0.6.0 @@ -45,12 +46,15 @@ , semigroups >=0.17 && <0.19 , QuickCheck >=2.8 && <2.10 , monad-time ==0.2 + , deepseq >=1.3 && <1.5 , hspec exposed-modules: PaymentChannel PaymentChannel.Types PaymentChannel.Util PaymentChannel.Test + Bitcoin.SpendCond.Cond + Bitcoin.SpendCond.Util other-modules: Bitcoin.Amount Bitcoin.Compare @@ -64,7 +68,6 @@ Bitcoin.Orphans Bitcoin.Signature Bitcoin.SinglePair - Bitcoin.SpendCond.Cond Bitcoin.SpendCond.Spec Bitcoin.Tx Bitcoin.Types @@ -112,7 +115,7 @@ build-depends: base >=4.7 && <5 , haskoin-core >=0.4.0 && <0.5.0 - , haskell-rbpcp-api + , rbpcp-api , base16-bytestring >=0.1.0 && <0.2.0 , bytestring >=0.10.0 && <0.11.0 , cereal >=0.5.0 && <0.6.0 @@ -127,6 +130,7 @@ , semigroups >=0.17 && <0.19 , QuickCheck >=2.8 && <2.10 , monad-time ==0.2 + , deepseq >=1.3 && <1.5 , hspec , bitcoin-payment-channel , base64-bytestring @@ -135,4 +139,34 @@ , tf-random , random , mtl + default-language: Haskell2010 + +benchmark bench + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + bench + default-extensions: OverloadedStrings RecordWildCards MultiParamTypeClasses TypeSynonymInstances FlexibleInstances FlexibleContexts FunctionalDependencies DataKinds ScopedTypeVariables + build-depends: + base >=4.7 && <5 + , haskoin-core >=0.4.0 && <0.5.0 + , rbpcp-api + , base16-bytestring >=0.1.0 && <0.2.0 + , bytestring >=0.10.0 && <0.11.0 + , cereal >=0.5.0 && <0.6.0 + , errors >=2.0.0 && <2.2.0 + , hexstring >=0.11.0 && <0.12.0 + , text >=1.2.0 && <1.3.0 + , time >=1.5.0 && <1.7.0 + , aeson >=0.11.0 && <1.1 + , scientific >=0.3.0 && <0.4.0 + , string-conversions >=0.4 && <0.5 + , tagged >=0.8 && <1.0 + , semigroups >=0.17 && <0.19 + , QuickCheck >=2.8 && <2.10 + , monad-time ==0.2 + , deepseq >=1.3 && <1.5 + , hspec + , criterion + , bitcoin-payment-channel default-language: Haskell2010 diff --git a/src/Bitcoin/Amount.hs b/src/Bitcoin/Amount.hs --- a/src/Bitcoin/Amount.hs +++ b/src/Bitcoin/Amount.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} module Bitcoin.Amount ( BtcAmount @@ -17,7 +18,7 @@ -- another BtcAmount, subtracts from its value. Adding two large amounts together will -- never overflow, nor will subtraction underflow. newtype BtcAmount = MkBitcoinAmount Word64 - deriving (Eq, Ord) + deriving (Eq, Ord, Generic, NFData) instance Show BtcAmount where show amount = show (toInteger amount) ++ " satoshi" diff --git a/src/Bitcoin/Compare.hs b/src/Bitcoin/Compare.hs --- a/src/Bitcoin/Compare.hs +++ b/src/Bitcoin/Compare.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Bitcoin.Compare where import Bitcoin.SpendCond.Cond @@ -17,24 +17,24 @@ Increase BtcAmount | Decrease BtcAmount | NoChange - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, NFData) data TxMismatch r = TxVersionMismatch Word32 Word32 | TxLocktimeMismatch (Maybe LockTimeDate) (Maybe LockTimeDate) | TxInMismatch (InMismatch r) | TxOutMisMatch OutMismatch - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, NFData) data InMismatch r = InPrevOutMismatch HT.OutPoint HT.OutPoint | InRdmScrMismatch r r | InSequenceMismatch Word32 Word32 - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, NFData) data OutMismatch = OutAddressMismatch HC.Address HC.Address - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, NFData) -- | Compare two transactions, ignoring output amounts and signature data, and return either diff --git a/src/Bitcoin/Dust.hs b/src/Bitcoin/Dust.hs --- a/src/Bitcoin/Dust.hs +++ b/src/Bitcoin/Dust.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-} module Bitcoin.Dust ( NonDusty @@ -17,7 +17,7 @@ -- |Connot represent an amount/output/transaction that contains "dust" data NonDusty a = NonDusty a - deriving (Eq, Show, Typeable) + deriving (Eq, Show, Typeable, Generic, NFData) class PossiblyDusty a where mkNonDusty :: a -> Either BtcError (NonDusty a) diff --git a/src/Bitcoin/Fee.hs b/src/Bitcoin/Fee.hs --- a/src/Bitcoin/Fee.hs +++ b/src/Bitcoin/Fee.hs @@ -3,7 +3,7 @@ -- import Bitcoin.Types import Bitcoin.Amount -import Bitcoin.Util (calcTxSize) +import Bitcoin.Util import qualified Network.Haskoin.Transaction as HT import qualified Data.Serialize as Bin import qualified Data.Aeson.Types as JSON @@ -24,7 +24,7 @@ type TxByteSize = Word -- |Specify a fee as satoshis per byte newtype SatoshisPerByte = SatoshisPerByte BtcAmount -- ^Fee in satoshis per byte - deriving (Eq, Show, Ord, Num, Enum, Real, Integral, Bin.Serialize, JSON.ToJSON, JSON.FromJSON) + deriving (Eq, Show, Ord, Num, Enum, Real, Integral, Bin.Serialize, JSON.ToJSON, JSON.FromJSON, NFData) instance HasFee SatoshisPerByte where absoluteFee txByteSize (SatoshisPerByte satoshisPerByte) = fromIntegral txByteSize * satoshisPerByte diff --git a/src/Bitcoin/LockTime/Types.hs b/src/Bitcoin/LockTime/Types.hs --- a/src/Bitcoin/LockTime/Types.hs +++ b/src/Bitcoin/LockTime/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Bitcoin.LockTime.Types ( BtcLockTime(..) @@ -12,7 +13,6 @@ import Data.Time.Clock import Data.Time.Clock.POSIX import Data.Time.Format () -- instance Show UTCTime -import Control.Monad.Time -- |Data type representing a Bitcoin LockTime, which specifies a point in time. @@ -22,11 +22,11 @@ -- |Specifies a point in time using a timestamp with 1-second accuracy (till 2106-02-07) data LockTimeDate = LockTimeDate Word32 - deriving (Eq, Ord, Typeable) + deriving (Eq, Ord, Typeable, Generic, NFData) -- | A value of "n" represents the point in time at which Bitcoin block number "n" appears data LockTimeBlockHeight = LockTimeBlockHeight Word32 - deriving (Eq, Ord, Typeable) + deriving (Eq, Ord, Typeable, Generic, NFData) instance BtcLockTime LockTimeBlockHeight where toWord32 (LockTimeBlockHeight w) = w diff --git a/src/Bitcoin/SpendCond/Cond.hs b/src/Bitcoin/SpendCond/Cond.hs --- a/src/Bitcoin/SpendCond/Cond.hs +++ b/src/Bitcoin/SpendCond/Cond.hs @@ -46,19 +46,19 @@ -- | Pay to something data Pay2 a = Pay2 a - deriving (Eq, Show, Typeable, Generic, JSON.ToJSON, JSON.FromJSON, Bin.Serialize) + deriving (Eq, Show, Typeable, Generic, JSON.ToJSON, JSON.FromJSON, Bin.Serialize, NFData) -- | Turns something into its SegWit counterpart data Witness a = Witness a - deriving (Eq, Show, Typeable, Generic, JSON.ToJSON, JSON.FromJSON, Bin.Serialize) + deriving (Eq, Show, Typeable, Generic, JSON.ToJSON, JSON.FromJSON, Bin.Serialize, NFData) -- | Hash a 'SpendCondition' data ScriptHash a = ScriptHash a - deriving (Eq, Show, Typeable, Generic, JSON.ToJSON, JSON.FromJSON, Bin.Serialize) + deriving (Eq, Show, Typeable, Generic, JSON.ToJSON, JSON.FromJSON, Bin.Serialize, NFData) -- | Wraps a 'SpendCondition' data Cond a = Cond a - deriving (Eq, Show, Typeable, Generic, JSON.ToJSON, JSON.FromJSON, Bin.Serialize) + deriving (Eq, Show, Typeable, Generic, JSON.ToJSON, JSON.FromJSON, Bin.Serialize, NFData) -- | Pay to script hash (P2SH) type P2SH c = Pay2 (ScriptHash (Cond c)) @@ -80,15 +80,20 @@ class HasSpendCond c ac | ac -> c where getCond :: ac -> c + mkCond :: c -> ac instance HasSpendCond c (Pay2 (Cond c)) where getCond = unwrap . unwrap + mkCond = Pay2 . Cond instance HasSpendCond c (Pay2 (ScriptHash (Cond c))) where getCond = unwrap . unwrap . unwrap + mkCond = Pay2 . ScriptHash . Cond instance HasSpendCond c (Pay2 (Witness (Cond c))) where getCond = unwrap . unwrap . unwrap + mkCond = Pay2 . Witness . Cond instance HasSpendCond c (Pay2 (ScriptHash (Witness (Cond c)))) where getCond = unwrap . unwrap . unwrap . unwrap + mkCond = Pay2 . ScriptHash . Witness . Cond inputCondScript :: HasSpendCond r t => InputG t a -> r inputCondScript MkInputG{..} = getCond btcInType @@ -157,9 +162,9 @@ -- ## P2PKH -- ########## data PubkeyHash = PubkeyHash PubKey - deriving (Eq, Show, Typeable, Generic, JSON.ToJSON, JSON.FromJSON, Bin.Serialize) + deriving (Eq, Show, Typeable, Generic, JSON.ToJSON, JSON.FromJSON, Bin.Serialize, NFData) data SpendPKH = SpendPKH BtcSig - deriving (Eq, Show, Typeable, Generic, JSON.ToJSON, JSON.FromJSON, Bin.Serialize) + deriving (Eq, Show, Typeable, Generic, JSON.ToJSON, JSON.FromJSON, Bin.Serialize, NFData) instance SpendCondition PubkeyHash where conditionScript (PubkeyHash pk) = Script diff --git a/src/Bitcoin/SpendCond/Util.hs b/src/Bitcoin/SpendCond/Util.hs new file mode 100644 --- /dev/null +++ b/src/Bitcoin/SpendCond/Util.hs @@ -0,0 +1,23 @@ +module Bitcoin.SpendCond.Util where + +import Bitcoin.Util +import qualified Network.Haskoin.Transaction as HT +import Bitcoin.SpendCond.Cond + + +-- | Create inputs from outputs that pay to the given redeemScript +getPrevIn :: forall r t. (SpendCondition r, HasSpendCond r t) => + HT.Tx + -> r + -> [InputG t ()] +getPrevIn tx rdmScr = + map (mapInputType mkCond . mkInput) $ catMaybes $ + zipWith checkOut [0..] (HT.txOut tx) + where + mkInput (idx,val) = mkNoSigTxIn (mkPrevOut idx) (fromIntegral val) rdmScr + mkPrevOut = HT.OutPoint (HT.txHash tx) + scrHash = hash160 $ conditionScript rdmScr + checkMatch idx (hash,val) = if hash == scrHash then Just (idx,val) else Nothing + checkOut idx out = + either (const Nothing) (checkMatch idx) + (decodeScriptHash (HT.scriptOutput out) >>= \sh -> Right (sh, HT.outValue out)) diff --git a/src/Bitcoin/Types.hs b/src/Bitcoin/Types.hs --- a/src/Bitcoin/Types.hs +++ b/src/Bitcoin/Types.hs @@ -8,7 +8,7 @@ where -import Bitcoin.Orphans as X +import Bitcoin.Orphans as X () import Bitcoin.Dust as X import Bitcoin.Amount as X import Bitcoin.Fee as X @@ -18,14 +18,13 @@ import Bitcoin.LockTime.Types as X import qualified Data.List.NonEmpty as NE -import qualified Data.ByteString as B import qualified Data.Serialize as Bin import qualified Data.Aeson.Types as JSON -import Data.Word (Word32) - import qualified Network.Haskoin.Transaction as HT import qualified Network.Haskoin.Script as HS import qualified Network.Haskoin.Crypto as HC +import Data.Word (Word32) +import Control.DeepSeq (NFData) data BtcTx inType sigData = BtcTx @@ -34,7 +33,7 @@ , btcOuts :: [BtcOut] , btcChgOut :: Maybe ChangeOut , btcLock :: Maybe LockTimeDate - } deriving (Eq, Show, Typeable, Generic, JSON.ToJSON, JSON.FromJSON) + } deriving (Eq, Show, Typeable, Generic, JSON.ToJSON, JSON.FromJSON, NFData) -- | Generic input @@ -47,19 +46,19 @@ , btcSequence :: Word32 -- ^ Input sequence (non-default only needed to enable locktime features) , btcSignFlag :: HS.SigHash -- ^ SigHash flag used to sign this input (default: SIGHASH_ALL) , btcKeyIndex :: KeyDeriveIndex -- ^ BIP32 key index for key used to sign this input (optional) - } deriving (Eq, Show, Typeable, Generic, Bin.Serialize, JSON.ToJSON, JSON.FromJSON) + } deriving (Eq, Show, Typeable, Generic, Bin.Serialize, JSON.ToJSON, JSON.FromJSON, NFData) -- | Generic output data OutputG outType = MkOutputG { btcOutAmount :: BtcAmount , btcOutType :: outType - } deriving (Eq, Show, Typeable, Generic, Bin.Serialize, JSON.ToJSON, JSON.FromJSON) + } deriving (Eq, Show, Typeable, Generic, Bin.Serialize, JSON.ToJSON, JSON.FromJSON, NFData) data BtcOut = BtcOut { btcAddress :: HC.Address , btcAmount :: NonDusty BtcAmount - } deriving (Eq, Show, Typeable, Generic, Bin.Serialize, JSON.ToJSON, JSON.FromJSON) + } deriving (Eq, Show, Typeable, Generic, Bin.Serialize, JSON.ToJSON, JSON.FromJSON, NFData) -- | An input/output pair signed with the SigHash flag SIG_SINGLE|ANYONECANPAY, -- meaning that only a single input/output pair is signed (SIG_SINGLE) -- @@ -71,7 +70,7 @@ data SigSinglePair t sd = SigSinglePair { singleInput :: InputG t sd , singleOutput :: BtcOut - } deriving (Eq, Show, Typeable, Generic, Bin.Serialize, JSON.ToJSON, JSON.FromJSON) + } deriving (Eq, Show, Typeable, Generic, Bin.Serialize, JSON.ToJSON, JSON.FromJSON, NFData) instance Eq t => Ord (SigSinglePair t BtcSig) where compare a b = compare (sigFlag a) (sigFlag b) @@ -83,10 +82,10 @@ , btcDustPolicy :: DustPolicy -- | For internal use. , btcAbsFee_ :: BtcAmount - } deriving (Eq, Show, Typeable, Generic, Bin.Serialize, JSON.ToJSON, JSON.FromJSON) + } deriving (Eq, Show, Typeable, Generic, Bin.Serialize, JSON.ToJSON, JSON.FromJSON, NFData) data DustPolicy = KeepDust | DropDust - deriving (Eq, Show, Typeable, Generic, Bin.Serialize, JSON.ToJSON, JSON.FromJSON) + deriving (Eq, Show, Typeable, Generic, Bin.Serialize, JSON.ToJSON, JSON.FromJSON, NFData) type UnsignedBtcTx t = BtcTx t () type UnsignedBtcIn t = InputG t () @@ -95,7 +94,7 @@ data BtcSig = MkBtcSig { bsSig :: HC.Signature , bsSigFlag :: HS.SigHash - } deriving (Eq, Show, Typeable, Generic, Bin.Serialize) + } deriving (Eq, Show, Typeable, Generic, Bin.Serialize, NFData) instance ToJSON BtcSig where toJSON = object . paySigKV @@ -138,7 +137,7 @@ data VerifyError = SigVerifyFail [(Word32,HC.PubKeyC,HC.Hash256,HC.Signature)] - deriving (Eq, Show, Typeable, Generic) -- , Bin.Serialize, JSON.ToJSON, JSON.FromJSON) + deriving (Eq, Show, Typeable, Generic) -- , Bin.Serialize, JSON.ToJSON, JSON.FromJSON, NFData) -- Defaults defaultTxVersion :: Word32 @@ -164,10 +163,14 @@ txAddOuts :: [BtcOut] -> BtcTx r a -> BtcTx r a txAddOuts outs tx = tx { btcOuts = btcOuts tx ++ outs } + -- Util mapSigData :: (a -> b) -> InputG t a -> InputG t b mapSigData f bin = bin { btcSigData = f $ btcSigData bin } +mapInputType :: (ta -> tb) -> InputG ta a -> InputG tb a +mapInputType f bin = bin { btcInType = f $ btcInType bin } + txMapSigData :: (a -> b) -> BtcTx t a -> BtcTx t b txMapSigData f tx@BtcTx{..} = tx { btcIns = NE.map mapIn btcIns } @@ -215,20 +218,6 @@ -- Conversion - --- | Create inputs from P2SH outputs that pay to the given redeemScript --- getPrevIn :: SpendCondition r => HT.Tx -> Pay2 (ScriptHash (Cond r)) -> [InputG r ()] --- getPrevIn tx rdmScr = --- map mkInput $ catMaybes $ --- zipWith relevantIndexes [0..] (HT.txOut tx) --- where --- scrHash = scriptHash160 $ conditionScript rdmScr --- mkInput (idx,val) = mkNoSigTxIn (mkPrevOut idx) (fromIntegral val) rdmScr --- mkPrevOut = HT.OutPoint (HT.txHash tx) --- checkMatch idx (hash,val) = if hash == scrHash then Just (idx,val) else Nothing --- relevantIndexes idx out = --- either (const Nothing) (checkMatch idx) --- (decodeScriptHash (HT.scriptOutput out) >>= \sh -> Right (sh, HT.outValue out)) instance (Bin.Serialize t, Bin.Serialize sd) => Bin.Serialize (BtcTx t sd) where put BtcTx{..} = diff --git a/src/PaymentChannel/Internal/ChanScript.hs b/src/PaymentChannel/Internal/ChanScript.hs --- a/src/PaymentChannel/Internal/ChanScript.hs +++ b/src/PaymentChannel/Internal/ChanScript.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module PaymentChannel.Internal.ChanScript ( module PaymentChannel.Internal.ChanScript @@ -23,7 +23,7 @@ cpReceiverPubKey :: RecvPubKey, -- |Channel expiration date/time cpLockTime :: LockTimeDate -} deriving (Eq, Show, Typeable, Generic) +} deriving (Eq, Show, Typeable, Generic, NFData) instance HasSendPubKey ChanParams where getSendPubKey = cpSenderPubKey diff --git a/src/PaymentChannel/Internal/Crypto/PubKey.hs b/src/PaymentChannel/Internal/Crypto/PubKey.hs --- a/src/PaymentChannel/Internal/Crypto/PubKey.hs +++ b/src/PaymentChannel/Internal/Crypto/PubKey.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric #-} module PaymentChannel.Internal.Crypto.PubKey ( IsPubKey(..) , SendPubKey(..) @@ -24,14 +24,14 @@ -- |Wrapper for value sender's public key newtype SendPubKey = MkSendPubKey { getSenderPK :: HC.PubKeyC -} deriving (Eq, Show, Serialize, FromJSON, ToJSON) +} deriving (Eq, Show, Serialize, Generic, FromJSON, ToJSON, NFData) instance IsPubKey SendPubKey where getPubKey = getSenderPK -- |Wrapper for value receiver's public key newtype RecvPubKey = MkRecvPubKey { getReceiverPK :: HC.PubKeyC -} deriving (Eq, Show, Serialize, FromJSON, ToJSON) +} deriving (Eq, Show, Serialize, Generic, FromJSON, ToJSON, NFData) instance IsPubKey RecvPubKey where getPubKey = getReceiverPK @@ -47,7 +47,7 @@ -- |Key index for a BIP32 root key newtype KeyDeriveIndex = KeyDeriveIndex Word32 - deriving (Eq, Show, Serialize, Ord, Num, Enum, Real, Integral, FromJSON, ToJSON) + deriving (Eq, Show, Serialize, Ord, Num, Enum, Real, Integral, FromJSON, ToJSON, NFData) class HasKeyIndex a where getKeyIndex :: a -> KeyDeriveIndex diff --git a/src/PaymentChannel/Internal/Error/User.hs b/src/PaymentChannel/Internal/Error/User.hs --- a/src/PaymentChannel/Internal/Error/User.hs +++ b/src/PaymentChannel/Internal/Error/User.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module PaymentChannel.Internal.Error.User where @@ -16,7 +16,7 @@ | 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 | StatusError HTTPError -- ^ Channel not ready for payment. 409=try again; 400=don't do that; 410=channel gone. - deriving (Eq, Generic) + deriving (Eq, Generic, NFData) instance Show PayChanError where show SigVerifyFailed = "Signature verification failed" diff --git a/src/PaymentChannel/Internal/Metadata/Types.hs b/src/PaymentChannel/Internal/Metadata/Types.hs --- a/src/PaymentChannel/Internal/Metadata/Types.hs +++ b/src/PaymentChannel/Internal/Metadata/Types.hs @@ -18,7 +18,7 @@ , mdSettledValue :: [SettleInfo] , mdUnsettledValue :: BtcAmount , mdChannelStatus :: PayChanStatus - } deriving (Eq, Typeable, Show, Generic) + } deriving (Eq, Typeable, Show, Generic, NFData) type MetadataIdx = MetadataI KeyDeriveIndex @@ -27,7 +27,7 @@ | PaymentInProgress | SettlementInProgress | ChanClosed - deriving (Eq, Typeable, Show, Read, Generic, Serialize) + deriving (Eq, Typeable, Show, Read, Generic, Serialize, NFData) instance Serialize a => Serialize (MetadataI a) where put Metadata{..} = diff --git a/src/PaymentChannel/Internal/Receiver/Types.hs b/src/PaymentChannel/Internal/Receiver/Types.hs --- a/src/PaymentChannel/Internal/Receiver/Types.hs +++ b/src/PaymentChannel/Internal/Receiver/Types.hs @@ -25,7 +25,7 @@ -- |Internal state object rpcState :: PayChanState BtcSig , rpcMetadata :: MetadataI kd -} deriving (Eq, Show, Typeable, Generic, Serialize) +} deriving (Eq, Show, Typeable, Generic, Serialize, NFData) instance HasSendPubKey (ServerPayChanI a) where getSendPubKey = getSendPubKey . rpcState instance HasRecvPubKey (ServerPayChanI a) where getRecvPubKey = getRecvPubKey . rpcState diff --git a/src/PaymentChannel/Internal/Settlement/Types.hs b/src/PaymentChannel/Internal/Settlement/Types.hs --- a/src/PaymentChannel/Internal/Settlement/Types.hs +++ b/src/PaymentChannel/Internal/Settlement/Types.hs @@ -46,7 +46,7 @@ data SettleInfo = SettleInfo { siValue :: BtcAmount , siPayCount :: Word64 - } deriving (Eq, Show, Generic, Serialize, FromJSON, ToJSON) + } deriving (Eq, Show, Generic, Serialize, FromJSON, ToJSON, NFData) diff --git a/src/PaymentChannel/Internal/Types.hs b/src/PaymentChannel/Internal/Types.hs --- a/src/PaymentChannel/Internal/Types.hs +++ b/src/PaymentChannel/Internal/Types.hs @@ -62,7 +62,7 @@ -- to guess valid resource identifiers, from looking at -- in-blockchain data. , pcsToken :: HC.Hash256 - } deriving (Eq, Show, Typeable, Generic, Serialize, ToJSON, FromJSON) + } deriving (Eq, Show, Typeable, Generic, Serialize, ToJSON, FromJSON, NFData) instance HasSendPubKey (PayChanState a) where getSendPubKey = getSendPubKey . pcsPayment instance HasRecvPubKey (PayChanState a) where getRecvPubKey = getRecvPubKey . pcsPayment @@ -76,7 +76,7 @@ spcState :: PayChanState sigData , -- |Payment-signing function spcPrvKey :: HC.PrvKeyC - } -- deriving (Eq, Show, Typeable, Generic, Serialize, ToJSON, FromJSON) + } deriving (Eq, Typeable, Generic, NFData) instance HasSendPubKey (ClientPayChanI a) where getSendPubKey = getSendPubKey . spcState instance HasRecvPubKey (ClientPayChanI a) where getRecvPubKey = getRecvPubKey . spcState diff --git a/src/PaymentChannel/Internal/Util.hs b/src/PaymentChannel/Internal/Util.hs --- a/src/PaymentChannel/Internal/Util.hs +++ b/src/PaymentChannel/Internal/Util.hs @@ -12,6 +12,7 @@ , module Data.Either , B.ByteString , Generic +, NFData , Typeable , Int64 , module Tagged @@ -24,7 +25,7 @@ import PaymentChannel.Internal.Serialization.JSON as JSONUtil - +import Control.DeepSeq (NFData) import Data.Serialize as Bin import Data.Serialize.Get as BinGet import Data.Serialize.Put as BinPut diff --git a/src/PaymentChannel/Test.hs b/src/PaymentChannel/Test.hs --- a/src/PaymentChannel/Test.hs +++ b/src/PaymentChannel/Test.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, DeriveGeneric, DeriveAnyClass #-} module PaymentChannel.Test ( module PaymentChannel.Test @@ -36,7 +36,7 @@ , initRecvAmount :: BtcAmount , initPayment :: SignedPayment , recvPrvKey :: HC.PrvKeyC - } + } deriving (Generic, NFData) data ChannelPairResult = ChannelPairResult { resInitPair :: ArbChannelPair @@ -45,7 +45,7 @@ , resSentAmounts :: [BtcAmount] , resRecvdAmounts :: [BtcAmount] , resPayList :: [SignedPayment] - } + } deriving (Generic, NFData) instance Show ArbChannelPair where show (ArbChannelPair spc rpc _ _ _ _) = diff --git a/src/PaymentChannel/Types.hs b/src/PaymentChannel/Types.hs --- a/src/PaymentChannel/Types.hs +++ b/src/PaymentChannel/Types.hs @@ -61,6 +61,7 @@ , SendPubKey(..),RecvPubKey(..),IsPubKey(..),HasSendPubKey(..),HasRecvPubKey(..) -- *Util + , module Bitcoin.SpendCond.Util , fromDate , getChanState -- , usesBlockHeight, dummyPayment @@ -76,6 +77,7 @@ import PaymentChannel.Internal.Metadata.Util import PaymentChannel.Internal.Serialization () import PaymentChannel.Internal.Class.Value (HasValue(..)) +import Bitcoin.SpendCond.Util import qualified PaymentChannel.Internal.Receiver.Util as S import qualified PaymentChannel.Internal.ChanScript as Script diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -3,6 +3,7 @@ import PaymentChannel.Test import PaymentChannel.Util +import Bitcoin.SpendCond.Util import qualified Network.Haskoin.Transaction as HT import qualified Network.Haskoin.Crypto as HC @@ -20,6 +21,7 @@ import Control.Monad.Identity (Identity(Identity)) import Debug.Trace +{-# ANN module ("HLint: ignore Redundant if"::String) #-} newtype TestM a = TestM { runTestId :: Identity a } @@ -61,26 +63,26 @@ testPaymentSessionM alwaysOneOutput ] ] --- , testGroup "Conversion" --- [ testProperty "RedeemScript" --- redeemScriptConversion --- ] --- , testGroup "Serialization" --- [ testGroup "JSON" --- [ testProperty "Payment" --- (jsonSerDeser :: Payment BtcSig -> Bool) --- , testProperty "ServerPayChan" --- (jsonSerDeser :: ServerPayChan -> Bool) --- ] --- , testGroup "Binary" --- [ testProperty "Payment" --- (binSerDeser :: Payment BtcSig -> Bool) --- , testProperty "PayChanState" --- (binSerDeser :: PayChanState BtcSig -> Bool) --- , testProperty "ChanParams" --- (binSerDeser :: ChanParams -> Bool) --- ] --- ] + , testGroup "Conversion" + [ testProperty "RedeemScript" + redeemScriptConversion + ] + , testGroup "Serialization" + [ testGroup "JSON" + [ testProperty "Payment" + (jsonSerDeser :: Payment BtcSig -> Bool) + , testProperty "ServerPayChan" + (jsonSerDeser :: ServerPayChan -> Bool) + ] + , testGroup "Binary" + [ testProperty "Payment" + (binSerDeser :: Payment BtcSig -> Bool) + , testProperty "PayChanState" + (binSerDeser :: PayChanState BtcSig -> Bool) + , testProperty "ChanParams" + (binSerDeser :: ChanParams -> Bool) + ] + ] ] redeemScriptConversion :: ChanParams -> Bool @@ -137,6 +139,13 @@ return $ if sum resSentAmounts == sum resRecvdAmounts then True else error $ show (resSentAmounts, resRecvdAmounts) +checkSpendCondTx :: ChannelPairResult -> TestM Bool +checkSpendCondTx cpr@ChannelPairResult{..} = do + tx <- mkSettleTx cpr + let rdmScr = pairRedeemScript $ pcsPayment $ spcState resSendChan + let ins = getPrevIn tx rdmScr :: [InputG (Pay2 (ScriptHash (Witness (Cond ChanParams)))) ()] + return $ show ins `trace` True + testPaymentSessionM :: (ChannelPairResult -> TestM Bool) -> ArbChannelPair @@ -162,7 +171,8 @@ where decodedObj = JSON.decode $ JSON.encode fp checkEquals serDeserVal = if serDeserVal /= fp then - error ("Ser/deser mismatch.\nOriginal: " ++ show fp ++ "\nCopy: " ++ show decodedObj) + error $ "Ser/deser mismatch.\nOriginal: " ++ + show fp ++ "\nCopy: " ++ show decodedObj else True @@ -173,9 +183,11 @@ 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 + Right res -> + if res /= fp then + error $ "Ser/deser mismatch.\nOriginal: " ++ show fp ++ + "\nCopy: " ++ show res + else + True