diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,11 +1,10 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, BangPatterns #-} 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 @@ -15,12 +14,13 @@ 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 mkCappedPayment :: Pay.BtcAmount -> (Pay.ClientPayChan, Pay.SignedPayment, Pay.BtcAmount) + mkCappedPayment = Pay.createPaymentCapped (Pay.sendChan arbPair) . Pay.Capped + (_,!payment,_) = mkCappedPayment 1 let multiMkVerify = Pay.runChanPair arbPair (fromIntegral <$> [1..payCount]) defaultMain - [ bench "Create payment" $ nfIO ( either (error . show) id <$> mkPayment 2 ) + [ bench "Create payment" $ nf mkCappedPayment 1 , bench "Verify payment" $ nfIO - ( either (error . show) id <$> Pay.acceptPayment (Pay.recvChan arbPair) payment ) + ( either (error . show) id <$> Pay.acceptPayment (Pay.toPaymentData payment) (Pay.recvChan arbPair) ) , 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.15.0. +-- This file has been generated from package.yaml by hpack version 0.17.0. -- -- see: https://github.com/sol/hpack name: bitcoin-payment-channel -version: 1.0.1.0 +version: 1.2.0.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. @@ -26,12 +26,11 @@ library hs-source-dirs: src - default-extensions: OverloadedStrings RecordWildCards MultiParamTypeClasses TypeSynonymInstances FlexibleInstances FlexibleContexts FunctionalDependencies DataKinds ScopedTypeVariables - ghc-options: -W + default-extensions: OverloadedStrings RecordWildCards MultiParamTypeClasses TypeSynonymInstances FlexibleInstances FlexibleContexts FunctionalDependencies KindSignatures DataKinds ScopedTypeVariables DeriveGeneric DeriveFunctor + ghc-options: -Wall 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 @@ -45,39 +44,53 @@ , tagged >=0.8 && <1.0 , semigroups >=0.17 && <0.19 , QuickCheck >=2.8 && <2.10 - , monad-time ==0.2 + , monad-time >=0.2 && <1.0 , deepseq >=1.3 && <1.5 + , rbpcp-api + , blockchain-restful-address-index-api , hspec + , data-default-class + , either + , transformers + , mtl exposed-modules: PaymentChannel PaymentChannel.Types PaymentChannel.Util PaymentChannel.Test + PaymentChannel.RBPCP.Parse + Bitcoin.BIP32 + Bitcoin.BIP32.Types + Bitcoin.BIP32.DetDerive + Bitcoin.Util + Bitcoin.Internal.Util + Bitcoin.Signature Bitcoin.SpendCond.Cond Bitcoin.SpendCond.Util other-modules: Bitcoin.Amount Bitcoin.Compare - Bitcoin.Config Bitcoin.Conversion Bitcoin.Dust Bitcoin.Error Bitcoin.Fee + Bitcoin.Internal.Orphans + Bitcoin.Internal.Types Bitcoin.LockTime.Types Bitcoin.LockTime.Util Bitcoin.Orphans - Bitcoin.Signature Bitcoin.SinglePair - Bitcoin.SpendCond.Spec Bitcoin.Tx Bitcoin.Types - Bitcoin.Util + Bitcoin.Types.ExpectFail + Bitcoin.Types.Tx + PaymentChannel.Client PaymentChannel.Internal.ChanScript PaymentChannel.Internal.Class.Value PaymentChannel.Internal.Config PaymentChannel.Internal.Crypto.PubKey PaymentChannel.Internal.Error - PaymentChannel.Internal.Error.Server + PaymentChannel.Internal.Error.Internal PaymentChannel.Internal.Error.Status PaymentChannel.Internal.Error.User PaymentChannel.Internal.Metadata.Types @@ -86,7 +99,7 @@ PaymentChannel.Internal.Payment.Create PaymentChannel.Internal.Payment.Types PaymentChannel.Internal.Payment.Verify - PaymentChannel.Internal.RBPCP.Parse + PaymentChannel.Internal.Receiver.Open PaymentChannel.Internal.Receiver.Settle PaymentChannel.Internal.Receiver.Types PaymentChannel.Internal.Receiver.Util @@ -99,23 +112,24 @@ PaymentChannel.Internal.Settlement.Script PaymentChannel.Internal.Settlement.Types PaymentChannel.Internal.Settlement.Util - PaymentChannel.Internal.State PaymentChannel.Internal.Types + PaymentChannel.Internal.Types.Hour + PaymentChannel.Internal.Types.MonadConf PaymentChannel.Internal.Util + PaymentChannel.Server Paths_bitcoin_payment_channel default-language: Haskell2010 -test-suite test-bitcoin-payment-channel +test-suite test-all type: exitcode-stdio-1.0 - main-is: Main.hs + main-is: Spec.hs hs-source-dirs: test - default-extensions: OverloadedStrings RecordWildCards MultiParamTypeClasses TypeSynonymInstances FlexibleInstances FlexibleContexts FunctionalDependencies DataKinds ScopedTypeVariables + default-extensions: OverloadedStrings RecordWildCards MultiParamTypeClasses TypeSynonymInstances FlexibleInstances FlexibleContexts FunctionalDependencies KindSignatures DataKinds ScopedTypeVariables DeriveGeneric DeriveFunctor ghc-options: -Wall 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 @@ -129,16 +143,28 @@ , tagged >=0.8 && <1.0 , semigroups >=0.17 && <0.19 , QuickCheck >=2.8 && <2.10 - , monad-time ==0.2 + , monad-time >=0.2 && <1.0 , deepseq >=1.3 && <1.5 + , rbpcp-api + , blockchain-restful-address-index-api , hspec + , data-default-class + , either + , transformers + , mtl , bitcoin-payment-channel + , hspec-discover , base64-bytestring , test-framework , test-framework-quickcheck2 , tf-random , random , mtl + other-modules: + BitcoinSpec + DetDeriveSpec + PayChanSpec + SpendCondSpec default-language: Haskell2010 benchmark bench @@ -146,11 +172,10 @@ main-is: Main.hs hs-source-dirs: bench - default-extensions: OverloadedStrings RecordWildCards MultiParamTypeClasses TypeSynonymInstances FlexibleInstances FlexibleContexts FunctionalDependencies DataKinds ScopedTypeVariables + default-extensions: OverloadedStrings RecordWildCards MultiParamTypeClasses TypeSynonymInstances FlexibleInstances FlexibleContexts FunctionalDependencies KindSignatures DataKinds ScopedTypeVariables DeriveGeneric DeriveFunctor 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 @@ -164,9 +189,15 @@ , tagged >=0.8 && <1.0 , semigroups >=0.17 && <0.19 , QuickCheck >=2.8 && <2.10 - , monad-time ==0.2 + , monad-time >=0.2 && <1.0 , deepseq >=1.3 && <1.5 + , rbpcp-api + , blockchain-restful-address-index-api , hspec + , data-default-class + , either + , transformers + , mtl , criterion , bitcoin-payment-channel default-language: Haskell2010 diff --git a/src/Bitcoin/BIP32.hs b/src/Bitcoin/BIP32.hs new file mode 100644 --- /dev/null +++ b/src/Bitcoin/BIP32.hs @@ -0,0 +1,6 @@ +module Bitcoin.BIP32 +( module X ) +where + +import Bitcoin.BIP32.Types as X +import Bitcoin.BIP32.DetDerive as X diff --git a/src/Bitcoin/BIP32/DetDerive.hs b/src/Bitcoin/BIP32/DetDerive.hs new file mode 100644 --- /dev/null +++ b/src/Bitcoin/BIP32/DetDerive.hs @@ -0,0 +1,75 @@ +module Bitcoin.BIP32.DetDerive +( module Bitcoin.BIP32.DetDerive +, module Bitcoin.BIP32.Types +) +where + +import Bitcoin.Internal.Types +import Bitcoin.BIP32.Types +import Data.Serialize as Bin +import Data.Serialize.Get as BinGet +import qualified Network.Haskoin.Crypto as HC +import Network.Haskoin.Crypto (DerivPathI(..)) + + +class DerivationSeed a where + toDerivSeed :: a -> ByteString + +-- | Deterministically derive a ChildKey from a sourceKey and a 'DerivationSeed' +detDerive + :: forall a sourceKey t k derivPath. + ( DerivationSeed a + , DerivPathElem Word32 derivPath + , IsChildKey sourceKey t k derivPath + ) + => sourceKey + -> a + -> t k +detDerive sourceKey seed = + mkChild sourceKey path + where + path :: derivPath + path = toDerivPath (to128bitSeed seed) + +to128bitSeed + :: DerivationSeed a + => a + -> (Word32, Word32, Word32, Word32) +to128bitSeed a = either (\e -> error $ "to128bitSeed bug: " ++ e) id $ + BinGet.runGet getWords (Bin.encode . HC.hash256 . toDerivSeed $ a) + where + getWords = do + w1 <- BinGet.getWord32be + w2 <- BinGet.getWord32be + w3 <- BinGet.getWord32be + w4 <- BinGet.getWord32be + return (w1,w2,w3,w4) + +-- ######## +-- ### Internal + +--newtype KeyIndex = KeyIndex Word32 + + +class DerivPathElem i derivPath where + derivBegin :: i -> derivPath + (/:|) :: derivPath -> i -> derivPath + +instance DerivPathElem Word32 HC.SoftPath where + derivBegin i = Deriv :/ cap31Bit i + (/:|) p i = p :/ cap31Bit i + +instance DerivPathElem Word32 HC.HardPath where + derivBegin i = Deriv :| cap31Bit i + (/:|) p i = p :| cap31Bit i + +cap31Bit :: Word32 -> Word32 +cap31Bit = (`mod` (0x80000000 :: Word32)) + +class AsDerivePath t derivPath where + toDerivPath :: t -> derivPath + +instance DerivPathElem i derivPath => AsDerivePath (i, i, i, i) derivPath where + toDerivPath (w1,w2,w3,w4) = derivBegin w1 /:| w2 /:| w3 /:| w4 + + diff --git a/src/Bitcoin/BIP32/Types.hs b/src/Bitcoin/BIP32/Types.hs new file mode 100644 --- /dev/null +++ b/src/Bitcoin/BIP32/Types.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric #-} +module Bitcoin.BIP32.Types +( -- * Key types + RootPrv +, RootPub +, RootKeyId +, External +, Internal +, ChildPair +, ChildPub +, ExtPub +, ExtPrv +, createRootPrv +, fromRootPrv + -- * Child key operations +, IsChildKey(..) +, HasKey(..) +, KeyDeriveIndex +, HasKeyIndex(..) + -- * Util +, keyId +, fromExternalPair +--, word32Index +--, word31Index +--, mkKeyIndex +) +where + + +import Bitcoin.Internal.Orphans () +import Bitcoin.Internal.Util +import qualified Network.Haskoin.Crypto as HC +import qualified Network.Haskoin.Node as HN +import Network.Haskoin.Crypto (DerivPathI(..)) +import qualified Data.ByteString.Char8 as C8 +import qualified Data.Serialize as Bin + + +createRootPrv :: ByteString -> RootPrv +createRootPrv = RootPrv . HC.makeXPrvKey + +-- | Source of all other key types +newtype RootPrv = RootPrv HC.XPrvKey deriving (Generic, NFData, Serialize, FromJSON, ToJSON) + +-- | The public counterpart of a 'RootPrv' +newtype RootPub = RootPub HC.XPubKey deriving (Eq, Show, Generic, NFData, Serialize, FromJSON, ToJSON) + +-- | Unique ID for a 'RootPrv'/'RootPub' pair +newtype RootKeyId = RootKeyId HC.Hash256 deriving (Eq, Show, Generic, NFData, Serialize, FromJSON, ToJSON) + +class HasKeyId rk where + keyId :: rk -> RootKeyId + +instance HasKeyId RootPub where + keyId (RootPub xPub) = + RootKeyId . HC.hash256 . Bin.encode $ xPub + +instance HasKeyId RootPrv where + keyId = keyId . fromRootPrv + +fromRootPrv :: RootPrv -> RootPub +fromRootPrv (RootPrv xPrv) = + RootPub . HC.deriveXPubKey $ xPrv + +-- | A child key derived from a 'RootPrv' or 'RootPub' +data ChildKey a = ChildKey a RootKeyId + deriving (Eq, Show, Functor, Generic) + +-- | A key pair where the public part can be derived without knowledge of the private part +-- (not safe if a single derived private key is exposed) +data External a = External (ChildKey a) HC.SoftPath + deriving (Eq, Show, Functor, Generic) + +-- | A key pair where the public part cannot be derived without knowledge of the private part +-- (safe if a single derived private key is exposed) +data Internal a = Internal (ChildKey a) HC.HardPath + deriving (Eq, Show, Functor, Generic) + +-- | Key pair, containing both private and public extended keys. +-- Derive subkeys using 'getKey' +data ChildPair = ChildPair { pairPriv :: !HC.XPrvKey + , pairPub' :: !HC.XPubKey } deriving (Eq, Show, Generic) + +-- | Public part only of a 'ChildPair' +newtype ChildPub = ChildPub HC.XPubKey + deriving (Eq, Show, Generic, NFData, Serialize, FromJSON, ToJSON) + +type ExtPub = External ChildPub +type ExtPrv = External ChildPair + +-- | +class IsChildKey sourceKey (t :: * -> *) k derivPath | t -> derivPath where + -- Create top-level child key + mkChild :: sourceKey -> derivPath -> t k + +instance IsChildKey RootPrv Internal ChildPair HC.HardPath where + mkChild rk@(RootPrv k) path = Internal + (childKeyWrap rk . fromChildPrv . HC.derivePath path $ k) path + + +instance IsChildKey RootPrv External ChildPair HC.SoftPath where + mkChild rk@(RootPrv k) path = External + (childKeyWrap rk . fromChildPrv . HC.derivePath path $ k) path + + +instance IsChildKey RootPrv External ChildPub HC.SoftPath where + mkChild k = fmap fromPair . mkChild k + +instance IsChildKey RootPub External ChildPub HC.SoftPath where + mkChild rk@(RootPub k) path = External hey path + where hey = childKeyWrap rk . ChildPub . HC.derivePubPath path $ k + + +fromChildPrv :: HC.XPrvKey -> ChildPair +fromChildPrv prv = ChildPair prv (HC.deriveXPubKey prv) + +fromPair :: ChildPair -> ChildPub +fromPair = ChildPub . pairPub' + +fromExternalPair :: External ChildPair -> External ChildPub +fromExternalPair = fmap fromPair + + +class HasKey t k key derivPath | t -> derivPath where + getKey :: t k -> key + +instance HasKey Internal ChildPair (HC.PrvKeyC, HC.XPubKey) HC.HardPath where + getKey (Internal (ChildKey (ChildPair k _) _) _) = + (HC.xPrvKey k, HC.deriveXPubKey k) + +instance HasKey Internal ChildPair HC.PrvKeyC HC.HardPath where + getKey pair = fst (getKey pair :: (HC.PrvKeyC, HC.XPubKey)) + +instance HasKey Internal ChildPair HC.XPubKey HC.HardPath where + getKey pair = snd (getKey pair :: (HC.PrvKeyC, HC.XPubKey)) + +instance HasKey Internal ChildPair HC.PubKeyC HC.HardPath where + getKey pair = HC.xPubKey $ getKey pair + +instance HasKey External ChildPair (HC.PrvKeyC, HC.XPubKey) HC.SoftPath where + getKey (External (ChildKey (ChildPair k _) _) _) = + (HC.xPrvKey k, HC.deriveXPubKey k) + +instance HasKey External ChildPair HC.PrvKeyC HC.SoftPath where + getKey pair = fst (getKey pair :: (HC.PrvKeyC, HC.XPubKey)) + +instance HasKey External ChildPair HC.XPubKey HC.SoftPath where + getKey pair = snd (getKey pair :: (HC.PrvKeyC, HC.XPubKey)) + +instance HasKey External ChildPair HC.PubKeyC HC.SoftPath where + getKey pair = HC.xPubKey $ getKey pair + +instance HasKey External ChildPub HC.XPubKey HC.SoftPath where + getKey (External (ChildKey (ChildPub pk) _) _) = pk + +instance HasKey External ChildPub HC.PubKeyC HC.SoftPath where + getKey = HC.xPubKey . getKey + + +-- ########## +-- ### Serialization + +instance Serialize a => Serialize (ChildKey a) where + get = ChildKey <$> get <*> get + put (ChildKey key kId) = put key >> put kId + +instance Serialize a => Serialize (External a) where + get = External <$> get <*> desSoftPath + put (External a p) = put a >> serPath p + +instance Serialize a => Serialize (Internal a) where + get = Internal <$> get <*> desHardPath + put (Internal a p) = put a >> serPath p + +serPath :: DerivPathI t -> PutM () +serPath sp = Bin.put (HN.VarInt . fromIntegral . C8.length $ strBuf) + >> Bin.putByteString strBuf + where strBuf = C8.pack $ HC.pathToStr sp + +desSoftPath :: Get HC.SoftPath +desSoftPath = do + strBuf <- varIntString + maybe (fail $ "failed to parse SoftPath from string: " ++ show strBuf) + return + (HC.parseSoft strBuf) + +desHardPath :: Get HC.HardPath +desHardPath = do + strBuf <- varIntString + maybe (fail $ "failed to parse HardPath from string: " ++ show strBuf) + return + (HC.parseHard strBuf) + +-- | Get 'HN.VarInt' length-prefixed 'String' +varIntString :: Get String +varIntString = do + HN.VarInt len <- Bin.get + C8.unpack <$> Bin.getByteString (fromIntegral len) + + + +-- |Key index for a BIP32 child key +newtype KeyDeriveIndex = KeyDeriveIndex Word32 + deriving (Eq, Show, Serialize, Ord, Num, Enum, Real, Integral, FromJSON, ToJSON, NFData) + +class HasKeyIndex a where + getKeyIndex :: a -> KeyDeriveIndex + +instance HasKeyIndex HC.XPubKey where + getKeyIndex = KeyDeriveIndex . HC.xPubIndex + + +-- ########### +-- ## UTIL + +childKeyWrap :: HasKeyId rk => rk -> a -> ChildKey a +childKeyWrap rk a = ChildKey a (keyId rk) + +{- +word32Index :: KeyDeriveIndex -> Word32 +word32Index (KeyDeriveIndex i) = i + +-- | Ignore most significant bit +word31Index :: KeyDeriveIndex -> Word32 +word31Index (KeyDeriveIndex i) = i `mod` (2^31 :: Word32) + +mkKeyIndex :: Word32 -> Maybe KeyDeriveIndex +mkKeyIndex i + | i >= 0 && i < 0x80000000 = Just $ KeyDeriveIndex i + | otherwise = Nothing +-} + +instance FromJSON a => FromJSON (External a) +instance FromJSON a => FromJSON (ChildKey a) +instance ToJSON a => ToJSON (External a) +instance ToJSON a => ToJSON (ChildKey a) +instance NFData ChildPair +instance NFData a => NFData (External a) +instance NFData a => NFData (Internal a) +instance NFData a => NFData (ChildKey a) diff --git a/src/Bitcoin/Compare.hs b/src/Bitcoin/Compare.hs --- a/src/Bitcoin/Compare.hs +++ b/src/Bitcoin/Compare.hs @@ -2,7 +2,7 @@ module Bitcoin.Compare where import Bitcoin.SpendCond.Cond -import Bitcoin.Util +import Bitcoin.Internal.Util import Data.Word (Word32) import qualified Data.List.NonEmpty as NE @@ -10,31 +10,33 @@ import qualified Network.Haskoin.Crypto as HC import GHC.Generics (Generic) +import Debug.Trace -data DiffInfo = DiffInfo [(HC.Address,ValDiff)] +newtype DiffInfo = DiffInfo [(HC.Address,ValDiff)] + data ValDiff = Increase BtcAmount | Decrease BtcAmount | NoChange - deriving (Eq, Show, Generic, NFData) + deriving (Eq, Show, Generic, NFData, ToJSON, FromJSON, Serialize) data TxMismatch r = TxVersionMismatch Word32 Word32 | TxLocktimeMismatch (Maybe LockTimeDate) (Maybe LockTimeDate) | TxInMismatch (InMismatch r) | TxOutMisMatch OutMismatch - deriving (Eq, Show, Generic, NFData) + deriving (Eq, Show, Generic, NFData, ToJSON, FromJSON, Serialize) data InMismatch r = InPrevOutMismatch HT.OutPoint HT.OutPoint | InRdmScrMismatch r r | InSequenceMismatch Word32 Word32 - deriving (Eq, Show, Generic, NFData) + deriving (Eq, Show, Generic, NFData, ToJSON, FromJSON, Serialize) data OutMismatch = OutAddressMismatch HC.Address HC.Address - deriving (Eq, Show, Generic, NFData) + deriving (Eq, Show, Generic, NFData, ToJSON, FromJSON, Serialize) -- | Compare two transactions, ignoring output amounts and signature data, and return either @@ -42,8 +44,8 @@ -- b) the difference in value for each output, between the two transactions. -- Eg. "valueDiff tx1 tx2", where tx1 pays 100000 satoshi to a single address "adr" and tx2 -- is the same except the value paid is 90000 satoshi, will return "DiffInfo [adr, Decrease 10000] -valueDiff :: forall r t a. (HasSpendCond r t, Eq t, Eq r) => - BtcTx t a -> BtcTx t a -> Either (TxMismatch r) DiffInfo +valueDiff :: forall r t a. (Eq r) => + BtcTx t r a -> BtcTx t r a -> Either (TxMismatch r) DiffInfo valueDiff oldTx newTx = compareProp oldTx newTx btcVer TxVersionMismatch >> compareProp oldTx newTx btcLock TxLocktimeMismatch @@ -56,10 +58,10 @@ compareOuts = zipWith outputDiff (btcOuts oldTx) (btcOuts newTx) -inputDiff :: (HasSpendCond r t, Eq t, Eq r) => InputG t a -> InputG t a -> Either (InMismatch r) () +inputDiff :: (Eq r) => InputG t r a -> InputG t r a -> Either (InMismatch r) () inputDiff oldIn newIn = compareProp oldIn newIn btcPrevOut InPrevOutMismatch - >> compareProp oldIn newIn inputCondScript InRdmScrMismatch + >> compareProp oldIn newIn btcCondScr InRdmScrMismatch >> compareProp oldIn newIn btcSequence InSequenceMismatch >> return () @@ -77,11 +79,11 @@ -- Check everything is equal except: 1) signature data (sig hash flag IS checked) -- 2) output amounts -eqIgnoreOutVal :: Eq t => - IgnoreSigData (BtcTx t BtcSig) -> IgnoreSigData (BtcTx t BtcSig) -> Bool -eqIgnoreOutVal tx1 tx2 = - fmap txClearOutVal tx1 == fmap txClearOutVal tx2 +eqIgnoreOutVal :: Eq r => + IgnoreSigData (BtcTx t r BtcSig) -> IgnoreSigData (BtcTx t r BtcSig) -> Bool +eqIgnoreOutVal tx1 tx2 = tx1 =~= tx2 where + a =~= b = fmap txClearOutVal a == fmap txClearOutVal b txClearOutVal tx = tx { btcOuts = map outputValClear (btcOuts tx) } outputValClear out = out { btcAmount = nullAmount } diff --git a/src/Bitcoin/Config.hs b/src/Bitcoin/Config.hs deleted file mode 100644 --- a/src/Bitcoin/Config.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Bitcoin.Config where - -import Bitcoin.Amount - - -configDustLimit :: BtcAmount -configDustLimit = 6000 - - - diff --git a/src/Bitcoin/Conversion.hs b/src/Bitcoin/Conversion.hs --- a/src/Bitcoin/Conversion.hs +++ b/src/Bitcoin/Conversion.hs @@ -8,6 +8,8 @@ import Bitcoin.SpendCond.Cond import Bitcoin.Types +import Bitcoin.Util +import Bitcoin.Internal.Types import qualified Data.List.NonEmpty as NE import qualified Data.ByteString as B @@ -16,22 +18,28 @@ import qualified Network.Haskoin.Crypto as HC -toTxOut :: ScriptPubKey outType => OutputG outType -> HT.TxOut +toTxOut :: forall r outType. ScriptPubKey r outType => OutputG outType r -> HT.TxOut toTxOut MkOutputG{..} = HT.TxOut (fromIntegral . toInteger $ btcOutAmount) - (Bin.encode $ asScript $ scriptPubKey btcOutType) + (Bin.encode $ asScript (scriptPubKey btcOutCond :: TxOutputScript outType)) -toInRaw :: B.ByteString -> InputG inType sigData -> HT.TxIn +toInRaw :: B.ByteString -> InputG inType r sigData -> HT.TxIn toInRaw inpScr MkInputG{..} = HT.TxIn btcPrevOut inpScr btcSequence -toUnsigTxIn :: InputG inType sigData -> HT.TxIn +toUnsigTxIn :: InputG inType r sigData -> HT.TxIn toUnsigTxIn = toInRaw B.empty -toSigTxIn :: SignatureScript t sigData => InputG t sigData -> HT.TxIn +toSigTxIn :: forall r sigData t. SignatureScript r sigData t => InputG t r sigData -> HT.TxIn toSigTxIn btcIn@MkInputG{..} = - toInRaw (Bin.encode $ asScript $ inputScript btcSigData btcInType) btcIn + toInRaw (Bin.encode $ asScript (inputScript btcSigData btcCondScr :: TxInputScript t)) btcIn +-- | Derive dummy private key from an input's prev_out txid +dummyPrvKey :: InputG t r sd -> HC.PrvKeyC +dummyPrvKey MkInputG{..} = + fromMaybe (error "Failed to decode PrvKeyC from 32 bytes") + . HC.decodePrvKey HC.makePrvKeyC . Bin.encode . HT.outPointHash $ btcPrevOut + toTxOut' :: BtcOut -> HT.TxOut toTxOut' (BtcOut adr val) = toTxOutRaw (adr, nonDusty val) @@ -45,10 +53,13 @@ toChangeTxOut val ChangeOut{..} = toTxOutRaw (btcChangeAddr, val) -getAllOuts :: BtcTx r a -> [HT.TxOut] +getAllOuts :: BtcTx t r sd -> [HT.TxOut] getAllOuts BtcTx{..} = map toTxOut' finalOuts ++ maybe [] mkChgOut btcChgOut where + btcAbsFee_ = getAbsFee . btcTxFee + getAbsFee (AbsoluteFee val) = val + getAbsFee (RelativeFee _) = error "BUG. getAllOuts: relative fee" -- | Remove zero-value outputs finalOuts = filter ((/= nullAmount) . btcAmount) btcOuts inVal = sum . NE.toList $ NE.map btcInValue btcIns @@ -56,18 +67,18 @@ mkChgOut co = [ toChangeTxOut (inVal - outVal - btcAbsFee_ co) co ] -toUnsignedTx :: BtcTx r a -> HT.Tx +toUnsignedTx :: BtcTx t r sd -> HT.Tx toUnsignedTx tx@BtcTx{..} = toTxWithIns (NE.map toUnsigTxIn btcIns) tx -toTxWithIns :: NE.NonEmpty HT.TxIn -> BtcTx r a -> HT.Tx +toTxWithIns :: NE.NonEmpty HT.TxIn -> BtcTx t r sd -> HT.Tx toTxWithIns binL tx@BtcTx{..} = HT.createTx btcVer (NE.toList binL) (getAllOuts tx) (maybe 0 toWord32 btcLock) -toHaskoinTx :: SignatureScript t ss => BtcTx t ss -> HT.Tx +toHaskoinTx :: SignatureScript r ss t => BtcTx t r ss -> HT.Tx toHaskoinTx tx@BtcTx{..} = toTxWithIns (NE.map toSigTxIn btcIns) tx diff --git a/src/Bitcoin/Dust.hs b/src/Bitcoin/Dust.hs --- a/src/Bitcoin/Dust.hs +++ b/src/Bitcoin/Dust.hs @@ -1,53 +1,52 @@ {-# LANGUAGE DeriveAnyClass, DeriveGeneric #-} module Bitcoin.Dust -( - NonDusty +( NonDustyAmount +, mkNonDusty , nonDusty , nullAmount -, PossiblyDusty(..) +, HasConfDustLimit(..) ) where import Bitcoin.Amount -import Bitcoin.Config -import Bitcoin.Util +import Bitcoin.Internal.Util import Bitcoin.Error --- |Connot represent an amount/output/transaction that contains "dust" -data NonDusty a = NonDusty a - deriving (Eq, Show, Typeable, Generic, NFData) +class Monad m => HasConfDustLimit m where + confDustLimit :: m BtcAmount -class PossiblyDusty a where - mkNonDusty :: a -> Either BtcError (NonDusty a) +-- | Cannot represent an amount that is less than the "dust limit" +newtype NonDustyAmount = NonDustyAmount BtcAmount + deriving (Eq, Show, Typeable, Generic, NFData) -nonDusty :: PossiblyDusty a => NonDusty a -> a -nonDusty (NonDusty a) = a +nonDusty :: NonDustyAmount -> BtcAmount +nonDusty (NonDustyAmount a) = a -nullAmount = either (error "BUG") id $ mkNonDusty (0 :: BtcAmount) +nullAmount :: NonDustyAmount +nullAmount = NonDustyAmount 0 -instance PossiblyDusty BtcAmount where - mkNonDusty amt = - if amt < configDustLimit && amt /= 0 - then Left $ DustOutput configDustLimit - else Right $ NonDusty amt +mkNonDusty :: HasConfDustLimit m => BtcAmount -> m (Either BtcError NonDustyAmount) +mkNonDusty amt = do + limit <- confDustLimit + if amt < limit && amt /= 0 + then return $ Left $ DustOutput limit + else return $ Right $ NonDustyAmount amt -instance Ord (NonDusty BtcAmount) where - compare (NonDusty a1) (NonDusty a2) = compare a1 a2 +instance Ord NonDustyAmount where + compare (NonDustyAmount a1) (NonDustyAmount a2) = compare a1 a2 -instance Serialize (NonDusty BtcAmount) where - put (NonDusty a) = put a - get = - (get :: Get BtcAmount) >>= - either (error "Dusty BtcAmount") return . mkNonDusty +instance Serialize NonDustyAmount where + put (NonDustyAmount a) = put a + get = do + a <- get + return $ NonDustyAmount a -instance ToJSON (NonDusty BtcAmount) where - toJSON (NonDusty a) = toJSON a +instance ToJSON NonDustyAmount where + toJSON (NonDustyAmount a) = toJSON a -instance FromJSON (NonDusty BtcAmount) where +instance FromJSON NonDustyAmount where parseJSON v = parseJSON v >>= \(amt :: BtcAmount) -> - case mkNonDusty amt of - Left _ -> fail $ "dusty BtcAmount: " ++ show amt - Right nda -> return nda + return (NonDustyAmount amt) diff --git a/src/Bitcoin/Error.hs b/src/Bitcoin/Error.hs --- a/src/Bitcoin/Error.hs +++ b/src/Bitcoin/Error.hs @@ -1,10 +1,51 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Bitcoin.Error where import Bitcoin.Amount -import Bitcoin.Util +import Bitcoin.Internal.Types +import Bitcoin.Types.ExpectFail +--import Data.List (intercalate) + data BtcError = - InsufficientFunds { eAmountMissing :: BtcAmount } - | DustOutput { eDustLimit :: BtcAmount } - deriving (Eq, Show, Typeable, Generic) + InsufficientFunds BtcAmount + | DustOutput BtcAmount + | WrongSigningKey [SignKeyError] + deriving (Eq, Typeable, Generic, NFData, ToJSON, FromJSON, Serialize) + +data SignKeyError + = SignKeyError + { skeInputIndex :: Word32 -- ^ Index of input for which error ocurred + , skePubKeys :: ExpectFail PubKeyC + } deriving (Eq, Typeable, Generic, NFData, ToJSON, FromJSON, Serialize) + +isKeyError :: BtcError -> Bool +isKeyError (WrongSigningKey _) = True +isKeyError _ = False + +instance Show BtcError where + show (InsufficientFunds amountMissing) = unwords + [ "insufficient funds, amount missing:", show amountMissing] + show (DustOutput dustLimit) = unwords + [ "dusty output in transaction, dust limit:", show dustLimit] + show (WrongSigningKey expecFails) = unwords + [ "transaction signing function was delivered a private key whose" + , "pubkey doesn't match the pubkey specified by HasSigner(signerPubKey)." + ] ++ unlines ["", concatMap show expecFails] + +instance Show SignKeyError where + show (SignKeyError inIdx expecFail) = unwords + [ "wrong sign key. index:" + , show inIdx ++ "," + , show expecFail + ] + +newtype Bug a = Bug a + deriving (Eq, Typeable, Generic, NFData, ToJSON, FromJSON, Serialize) + +instance Exception a => Exception (Bug a) +instance Exception BtcError + +instance Show a => Show (Bug a) where + show (Bug a) = unwords ["BUG:", show a] + diff --git a/src/Bitcoin/Fee.hs b/src/Bitcoin/Fee.hs --- a/src/Bitcoin/Fee.hs +++ b/src/Bitcoin/Fee.hs @@ -3,32 +3,33 @@ -- import Bitcoin.Types import Bitcoin.Amount -import Bitcoin.Util -import qualified Network.Haskoin.Transaction as HT +import PaymentChannel.Internal.Util import qualified Data.Serialize as Bin import qualified Data.Aeson.Types as JSON -- |Objects from which a Bitcoin fee can be calculated, --- given a transaction (yeah you need to create a tx twice). +-- given a transaction class HasFee a where - absoluteFee :: TxByteSize -> a -> BtcAmount + absoluteFee :: BtcAmount -> TxByteSize -> a -> BtcAmount --- |For compatibility +-- |Constant fee instance HasFee BtcAmount where - absoluteFee _ = id -- Same as constant fee + absoluteFee _ _ = id -- Same as constant fee -data Constant = Constant BtcAmount +newtype Constant = Constant BtcAmount + deriving (Eq, Generic, NFData) instance HasFee Constant where - absoluteFee _ (Constant amt) = amt + absoluteFee _ _ (Constant amt) = amt 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, NFData) instance HasFee SatoshisPerByte where - absoluteFee txByteSize (SatoshisPerByte satoshisPerByte) = + absoluteFee _ txByteSize (SatoshisPerByte satoshisPerByte) = fromIntegral txByteSize * satoshisPerByte +{- mkRelativeFeeTx :: HasFee fee => fee -- ^Desired (per-byte) transaction fee @@ -40,6 +41,4 @@ pass2Tx = mkTxSizeFee pass1Tx pass1Tx = mkTxFunc (0 :: BtcAmount) mkTxSizeFee tx = mkTxFunc $ absoluteFee (calcTxSize tx) fee - - - +-} diff --git a/src/Bitcoin/Internal/Orphans.hs b/src/Bitcoin/Internal/Orphans.hs new file mode 100644 --- /dev/null +++ b/src/Bitcoin/Internal/Orphans.hs @@ -0,0 +1,39 @@ +module Bitcoin.Internal.Orphans where + +import qualified Network.Haskoin.Crypto as HC +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString as BS +import Data.Aeson +import Data.String.Conversions (cs) +import qualified Network.Haskoin.Script as HS +import qualified Data.Ord as Ord + + + +-- | SigSingle first, then SigNone, then SigAll +instance Ord.Ord HS.SigHash where + compare s1 s2 = + case (s1,s2) of + (HS.SigSingle _, _) -> Ord.LT + (HS.SigNone _, HS.SigSingle _) -> Ord.GT + (HS.SigNone _, HS.SigNone _) -> Ord.EQ + (HS.SigNone _, HS.SigAll _) -> Ord.LT + (HS.SigAll _, _) -> Ord.GT + (HS.SigUnknown{}, _) -> Ord.GT + ( _, HS.SigUnknown{}) -> Ord.GT + + +instance FromJSON HC.Hash256 where + parseJSON = + withText "Hash256" $ \src -> do + bs <- decodeHex . BS.take 64 . cs $ src + let parseErr = "parse fail. input data: " ++ show src + maybe (fail parseErr) return (HC.bsToHash256 bs) + where + decodeHex src = let (res,leftovers) = B16.decode src in + if leftovers == BS.empty + then return res + else fail $ "failed to decode from: " ++ show src + +instance ToJSON HC.Hash256 where + toJSON = String . cs . B16.encode . HC.getHash256 diff --git a/src/Bitcoin/Internal/Types.hs b/src/Bitcoin/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Bitcoin/Internal/Types.hs @@ -0,0 +1,41 @@ +module Bitcoin.Internal.Types +( module X +, module Bin, module BinGet, module BinPut +, module JSON, module JSONT +, module Sci +, module Data.Maybe +, module Data.Either +, B.ByteString +, Generic +, NFData +, Typeable +, Int64 +, module Tagged +, HC.PubKeyC +, Exception +) + +where + + +import Control.DeepSeq (NFData) +import Data.Serialize as Bin +import Data.Serialize.Get as BinGet +import Data.Serialize.Put as BinPut +import Data.Aeson as JSON hiding (Result(..), encode, decode) +import Data.Aeson.Types as JSONT hiding (Result(..)) +import Data.Scientific as Sci + +--import Bitcoin.Internal.Orphans as X () +import Data.Word as X (Word32) +import Data.Maybe +import Data.Either +import Data.Tagged as Tagged hiding (witness) +import qualified Data.ByteString as B +import qualified Data.Aeson.Types as JSON +import Data.Int (Int64) +import GHC.Generics (Generic) + +import Data.Typeable (Typeable) +import qualified Network.Haskoin.Crypto as HC +import Control.Exception diff --git a/src/Bitcoin/Internal/Util.hs b/src/Bitcoin/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/src/Bitcoin/Internal/Util.hs @@ -0,0 +1,100 @@ +module Bitcoin.Internal.Util +( module Bitcoin.Internal.Util +, module X +, cs +, fmapL +, (<>) +, module Ctrl +) +where + + +import Bitcoin.Internal.Types as X +import Data.Serialize as Bin +import Data.Serialize.Get as BinGet +import qualified Data.ByteString as B +import qualified Data.Aeson.Types as JSON +import qualified Data.ByteString.Base16 as B16 + +import qualified Data.ByteString.Char8 as C +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Typeable (Typeable, typeOf) +import qualified Network.Haskoin.Crypto as HC + +import Data.String.Conversions (cs) +--import Data.Either (lefts) +import Data.EitherR (fmapL) +import Data.Monoid ((<>)) +import Control.Monad as Ctrl (forM, mapM, (>=>), (<=<)) + + +toInt :: (Integral a, Num b) => a -> b +toInt = fromIntegral + + +getIndexSafe :: [a] -> Int -> Maybe a +getIndexSafe l i = if i < 0 || i+1 > length l then Nothing else Just $ l !! i + +toHexString :: B.ByteString -> String +toHexString = C.unpack . B16.encode + +toHexBS :: B.ByteString -> B.ByteString +toHexBS = B16.encode + +fromHexBS :: B.ByteString -> B.ByteString +fromHexBS = fst . B16.decode + +fromHexString :: String -> B.ByteString +fromHexString hexStr = + case (B16.decode . C.pack) hexStr of + (bs,e) -> + if B.length e /= 0 then B.empty else bs + +serialize :: Bin.Serialize a => a -> B.ByteString +serialize = Bin.encode + +deserEither :: forall a. (Typeable a, Bin.Serialize a) => B.ByteString -> Either String a +deserEither bs = do + let eitherRes' = BinGet.runGetPartial (Bin.get :: BinGet.Get a) bs + handleResult eitherRes' + where + handleResult eitherRes = case eitherRes of + BinGet.Done val _ -> Right val + BinGet.Partial feedFunc -> handleResult $ feedFunc B.empty + BinGet.Fail e leftoverBS -> Left $ + "Type: " ++ show (typeOf (undefined :: a)) ++ + ". Error: " ++ e ++ + ". Data consumed (" ++ show offset ++ " bytes): " ++ + toHexString (B.take offset bs) ++ + ". Unconsumed data: (" ++ show ( B.length bs - fromIntegral offset ) ++ + " bytes): " ++ + toHexString leftoverBS + where offset = B.length bs - B.length leftoverBS + +deserHex :: (Typeable a, Bin.Serialize a) => T.Text -> JSON.Parser a +deserHex = either + (fail . ("failed to decode hex: " ++)) return . + deserEither . fromHexBS . encodeUtf8 + +serHex :: Bin.Serialize a => a -> T.Text +serHex = decodeUtf8 . toHexBS . Bin.encode + + +-- dummyPubkey :: HC.PubKeyC +-- dummyPubkey = mkDummyPubkey "0323dcd0a7481cb90e3583923701b14d0b6757ebd76bf5b49e696c61f193d7a489" + +mkDummyPubkey :: B.ByteString -> HC.PubKeyC +mkDummyPubkey hexStr = + either (error "mkDummyPubkey: Invalid dummy pubkey data") id (Bin.decode pkBS) + where pkBS = fst $ B16.decode hexStr + + +mkDummySig :: B.ByteString -> HC.Signature +mkDummySig hexStr = + fromMaybe (error "dummySig: Invalid dummy sig data") (HC.decodeDerSig sigBS) + where sigBS = fst $ B16.decode hexStr + +dummySig :: HC.Signature +dummySig = mkDummySig "304402204202cdb61cb702aa62de312a8e5eada817d90c4e26c8b696780b14d1576f204f02203c134d0acb057d917508ca9baab241a4f66ebea32f7acceeaf621a334927e17701" + 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 @@ -4,6 +4,7 @@ BtcLockTime(..) , LockTimeDate(..) , LockTimeBlockHeight(..) +, LockTimeParseError(..) , fromDate ) where @@ -17,9 +18,18 @@ -- |Data type representing a Bitcoin LockTime, which specifies a point in time. class BtcLockTime a where - parseLockTime :: Word32 -> Maybe a + parseLockTime :: Word32 -> Either LockTimeParseError a toWord32 :: a -> Word32 +data LockTimeParseError = + DateParseFail + | BlockHeightParseFail + deriving (Eq, Generic, NFData, ToJSON, FromJSON, Serialize) + +instance Show LockTimeParseError where + show DateParseFail = "failed to parse unix timestamp from uint32 lockTime" + show BlockHeightParseFail = "failed to parse block height from uint32 lockTime" + -- |Specifies a point in time using a timestamp with 1-second accuracy (till 2106-02-07) data LockTimeDate = LockTimeDate Word32 deriving (Eq, Ord, Typeable, Generic, NFData) @@ -31,12 +41,14 @@ instance BtcLockTime LockTimeBlockHeight where toWord32 (LockTimeBlockHeight w) = w parseLockTime tstamp - | tstamp > 0 && tstamp < 500000000 = Just $ LockTimeBlockHeight tstamp - | otherwise = Nothing + | tstamp > 0 && tstamp < 500000000 = + Right $ LockTimeBlockHeight tstamp + | otherwise = + Left BlockHeightParseFail instance BtcLockTime LockTimeDate where toWord32 (LockTimeDate w) = w - parseLockTime = fromDate . posixSecondsToUTCTime . fromIntegral + parseLockTime = maybe (Left DateParseFail) Right . fromDate . posixSecondsToUTCTime . fromIntegral -- | Convert a 'Data.Time.Clock.UTCTime' to a 'LockTimeDate'. @@ -62,7 +74,7 @@ parseJSONLockTime :: forall a. BtcLockTime a => Scientific -> Parser a parseJSONLockTime sci = - (parseLockTime <$> parseJSONWord sci) >>= maybe (fail "invalid locktime") return + (parseLockTime <$> parseJSONWord sci) >>= either (fail . show) return encodeJSONLockTime :: BtcLockTime a => a -> Value encodeJSONLockTime blt = Number $ scientific (fromIntegral $ toWord32 blt) 0 @@ -83,4 +95,4 @@ parseBinLockTime :: forall a. BtcLockTime a => Get a parseBinLockTime = getWord32le >>= - maybe (fail "invalid locktime") return . parseLockTime + either (fail . show) return . parseLockTime diff --git a/src/Bitcoin/LockTime/Util.hs b/src/Bitcoin/LockTime/Util.hs --- a/src/Bitcoin/LockTime/Util.hs +++ b/src/Bitcoin/LockTime/Util.hs @@ -1,17 +1,10 @@ module Bitcoin.LockTime.Util -( - module Bitcoin.LockTime.Util +( module Bitcoin.LockTime.Util , module Bitcoin.LockTime.Types -, Hour ) where import Bitcoin.LockTime.Types -import PaymentChannel.Internal.Config -import PaymentChannel.Internal.Util - -import Data.Word (Word32) -import Data.Time.Clock import Data.Time.Clock.POSIX import Data.Time.Format () -- instance Show UTCTime import Control.Monad.Time @@ -20,8 +13,17 @@ class HasLockTimeDate a where getLockTimeDate :: a -> LockTimeDate -isLocked :: (MonadTime m, HasLockTimeDate a) => a -> m Bool -isLocked a = do - now <- fromIntegral . round . utcTimeToPOSIXSeconds <$> currentTime - return $ now + toSeconds configSettlePeriod < toWord32 (getLockTimeDate a) +instance HasLockTimeDate LockTimeDate where + getLockTimeDate = id +type Seconds = Word + +isLocked :: (MonadTime m, HasLockTimeDate a) + => Seconds -- ^ No longer locked this number of seconds *before* actual expiration time. + -- Gives this many seconds to publish the settlement transaction before + -- actual lockTime expires. + -> a + -> m Bool +isLocked settlePeriodSeconds a = do + now :: Integer <- round . utcTimeToPOSIXSeconds <$> currentTime + return $ now + fromIntegral settlePeriodSeconds < fromIntegral (toWord32 $ getLockTimeDate a) diff --git a/src/Bitcoin/Orphans.hs b/src/Bitcoin/Orphans.hs --- a/src/Bitcoin/Orphans.hs +++ b/src/Bitcoin/Orphans.hs @@ -1,20 +1,2 @@ module Bitcoin.Orphans where -import qualified Network.Haskoin.Transaction as HT -import qualified Network.Haskoin.Crypto as HC -import qualified Network.Haskoin.Script as HS -import qualified Data.Ord as Ord - - - --- | SigSingle first, then SigNone, then SigAll -instance Ord.Ord HS.SigHash where - compare s1 s2 = - case (s1,s2) of - (HS.SigSingle _, _) -> Ord.LT - (HS.SigNone _, HS.SigSingle _) -> Ord.GT - (HS.SigNone _, HS.SigNone _) -> Ord.EQ - (HS.SigNone _, HS.SigAll _) -> Ord.LT - (HS.SigAll _, _) -> Ord.GT - (HS.SigUnknown{}, _) -> Ord.GT - ( _, HS.SigUnknown{}) -> Ord.GT diff --git a/src/Bitcoin/Signature.hs b/src/Bitcoin/Signature.hs --- a/src/Bitcoin/Signature.hs +++ b/src/Bitcoin/Signature.hs @@ -1,132 +1,273 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Bitcoin.Signature -( - module Bitcoin.Conversion -, TransformSigData(..) -, signTx, signSettleTx +( -- * Interface to fill out + TransformSigData(..) +, HasSigner(..) + -- * Provided functions: sign tx, verify tx +, signTx +, signChangeTx , verifyTx + -- * Runners +, runSimple +, runExtDet +, runDummy +, SignM +, SignSimpleM +, SignDerivM +, SignDummyM +, HasSigningKey + -- * Re-exports +, module Bitcoin.Conversion +, module X ) where import Bitcoin.Conversion import Bitcoin.Util +import Bitcoin.Internal.Util +import Bitcoin.BIP32.DetDerive +import Data.Default.Class as X (Default (def)) + import Data.Word (Word32) import Control.Monad (zipWithM) import qualified Data.List.NonEmpty as NE import qualified Network.Haskoin.Script as HS import qualified Network.Haskoin.Crypto as HC +import qualified Control.Monad.Reader as R +--import Debug.Trace -class SpendCondition r => TransformSigData newSd oldSd r where - mkSigData :: oldSd -> BtcSig -> r -> newSd +-- | Identifies a signer whose signature produces newSigData +class SpendCondition r => HasSigner newSigData r where + signerPubKey :: r -> Tagged newSigData HC.PubKeyC +-- -- | Defines which 'HS.SigHash' flag to use when signing an input from 'oldSigData' +--class HasSignFlag oldSigData where +-- getSignFlag :: oldSigData -> HS.SigHash +-- | Defines how to transform old signature data type into a new one (by adding signatures) +class (HasSigner newSigData r) --, HasSignFlag oldSigData) + => TransformSigData newSigData oldSigData r | newSigData oldSigData -> r where + mkSigData :: oldSigData -- ^ Old signature data, needs next 'BtcSig' added to it + -> BtcSig -- ^ Signature produced by signing input + -> Tagged r newSigData --- | Sign transaction -signTx :: forall t r ss oldSd m. - (Monad m, TransformSigData ss oldSd r, SignatureScript t ss - , SpendFulfillment ss r, HasSpendCond r t) => - (KeyDeriveIndex -> m HC.PrvKeyC) - -> BtcTx t oldSd - -> m (Either BtcError (BtcTx t ss)) -signTx signFunc tx@BtcTx{..} = signReplaceInputs signFunc tx --- | Sign transaction with added inputs and change output -signSettleTx :: forall t r ss oldSd m. - ( Monad m - , HasSpendCond r t, SpendFulfillment ss r, TransformSigData ss oldSd r, SignatureScript t ss - ) => - (KeyDeriveIndex -> m HC.PrvKeyC) - -> ChangeOut - -> BtcTx t oldSd - -> m (Either BtcError (BtcTx t ss)) -signSettleTx signFunc chgOut tx@BtcTx{..} = mkRelativeFeeTxM (btcTxFee chgOut) mkTx - where mkTx fee = signReplaceInputs signFunc (txWithChange fee) - txWithChange fee = setTxRawFee fee $ setChangeOut chgOut tx +-- ############## +-- ### Internal interfaces: abstract over source private key types +class Monad m => MonadSign m signKey | m -> signKey where + signGetKey :: m signKey + getSignConf :: m SignConf -signReplaceInputs :: forall t r ss oldSd m. - ( Monad m - , TransformSigData ss oldSd r - , SignatureScript t ss - , SpendFulfillment ss r - , SpendCondition r - , HasSpendCond r t - ) => - (KeyDeriveIndex -> m HC.PrvKeyC) - -> BtcTx t oldSd - -> m (Either BtcError (BtcTx t ss)) -signReplaceInputs f tx = - if availableVal tx >= 0 - then signInputs f tx >>= \ins -> return $ Right tx { btcIns = ins } - else return . Left . InsufficientFunds . fromIntegral . abs . availableVal $ tx +class HasSigningKey key t r oldSigData where + getSignKey :: InputG t r oldSigData -> key -> HC.PrvKeyC -signInputs :: forall t r ss oldSd m. - ( Monad m - , TransformSigData ss oldSd r - , SignatureScript t ss - , SpendFulfillment ss r - , SpendCondition r - , HasSpendCond r t - ) => - (KeyDeriveIndex -> m HC.PrvKeyC) - -> BtcTx t oldSd - -> m (NE.NonEmpty (InputG t ss)) -signInputs getKey tx@BtcTx{..} = - unsafeCastNE <$> zipWithM signIt [0..] (NE.toList btcIns) +-- Simple +instance HasSigningKey HC.PrvKeyC t r oldSig where + getSignKey _ = id +-- BIP32+Deterministic derivation +instance DerivationSeed r => HasSigningKey RootPrv t r oldSig where + getSignKey MkInputG{..} key = + getKey (detDerive key btcCondScr :: External ChildPair) +-- Dummy +instance HasSigningKey () t r oldSig where + getSignKey inp _ = dummyPrvKey inp + +-- | Generic signing monad. Run with e.g. 'runSimple' +newtype SignM key a = SignM { getSignM :: R.Reader (SignData key) a } + deriving (Functor, Applicative, Monad, R.MonadReader (SignData key)) + +type SignSimpleM = SignM HC.PrvKeyC + +type SignDerivM = SignM RootPrv + +type SignDummyM = SignM () + +-- | +newtype SignConf + = SignConf + { doSignCheck :: Bool -- ^ (Default: True) When signing, check whether signing private key's pubkey matches specified script pubkey + } + +instance Default SignConf where + def = SignConf + { doSignCheck = True } + +-- | +data SignData kd + = SignData + { sdKey :: kd -- ^ Private key data + , sdConf :: SignConf + } + +instance MonadSign (SignM key) key where + signGetKey = R.asks sdKey + getSignConf = R.asks sdConf +--instance MonadSign SignDerivM RootPrv where +-- signGetKey = R.asks sdKey +-- getSignConf = R.asks sdConf +--instance MonadSign SignDummyM () where +-- signGetKey = R.asks sdKey +-- getSignConf = R.asks sdConf + + +-- | Run 'SignM' using a 'HC.PrvKeyC' private key +runSimple + :: HC.PrvKeyC + -> SignSimpleM a + -> a +runSimple key = + (`R.runReader` SignData key def) . getSignM + +-- | Run using a BIP-32 extended root private key as source key, +-- with determinisitic key derivation. +runExtDet + :: RootPrv + -> SignDerivM a + -> a +runExtDet rootKey = + (`R.runReader` SignData rootKey def) . getSignM + +-- | TEST: Run using dummy private key. Used e.g. for producing transactions +-- to test serialization length, for calculating tx fees relative to tx size. +runDummy + :: SignDummyM a + -> a +runDummy = + (`R.runReader` SignData () noSigCheck) . getSignM where - signIt idx inp@MkInputG{..} = do - prv <- getKey btcKeyIndex - let rdmScr = getCond btcInType :: r - let rawSig = getHashForSig tx rdmScr idx btcSignFlag `HC.signMsg` prv - let sigData = mkSigData btcSigData (MkBtcSig rawSig btcSignFlag) rdmScr - return $ mapSigData (const sigData) inp + noSigCheck = SignConf { doSignCheck = False } -verifyTx :: (SpendFulfillment ss r, SpendCondition r, HasSpendCond r t) => - BtcTx t ss -> Either VerifyError () + + +signTx :: forall m t r newSigData oldSd signKey. + ( TransformSigData newSigData oldSd r + , MonadSign m signKey + , HasSigningKey signKey t r oldSd + ) => + BtcTx t r oldSd + -> m (Either BtcError (BtcTx t r newSigData)) +signTx tx = + if availableVal tx < 0 + then return . Left . InsufficientFunds . fromIntegral . abs . availableVal $ tx + else do + insE <- signInputs tx + let replaceTxIns ins = tx { btcIns = ins } + replacedIns = replaceTxIns <$> fmapL WrongSigningKey insE + return replacedIns + +signChangeTx :: forall m t r newSd oldSd signKey. + ( SignatureScript r newSd t + , TransformSigData newSd oldSd r + , MonadSign m signKey + , HasSigningKey signKey t r oldSd + ) => + BtcTx t r oldSd + -> ChangeOut + -> m (Either BtcError (BtcTx t r newSd)) +signChangeTx tx@BtcTx{..} chgOut = + mkRelFeeFunc mkTx + where + mkTx :: BtcAmount -> m (Either BtcError (BtcTx t r newSd)) + mkTx fee = signTx (txWithChange fee) + txWithChange :: BtcAmount -> BtcTx t r oldSd + txWithChange fee = setTxRawFee fee $ setChangeOut chgOut tx + mkRelFeeFunc :: (BtcAmount -> m (Either BtcError (BtcTx t r newSd))) + -> m (Either BtcError (BtcTx t r newSd)) + mkRelFeeFunc = absOrRelFee mkRelativeFeeTxM mkRelativeFeeTxM (btcTxFee chgOut) + + +signInputs :: forall m t r newSigData oldSd signKey. + ( TransformSigData newSigData oldSd r + , MonadSign m signKey + , HasSigningKey signKey t r oldSd + ) + => BtcTx t r oldSd + -> m (Either [SignKeyError] (NE.NonEmpty (InputG t r newSigData))) +signInputs tx@BtcTx{..} = do + resE <- zipWithM (signInput tx) [0..] (NE.toList btcIns) + let errors = lefts (resE :: [Either SignKeyError (InputG t r newSigData)]) + return $ if null errors + then Right $ unsafeCastNE (rights resE) + else Left errors + +signInput + :: forall m t r signKey oldSigData newSigData. + ( TransformSigData newSigData oldSigData r + , MonadSign m signKey + , HasSigningKey signKey t r oldSigData + ) + => BtcTx t r oldSigData + -> Word32 + -> InputG t r oldSigData + -> m (Either SignKeyError (InputG t r newSigData)) +signInput tx idx inp@MkInputG{..} = do + SignConf{..} <- getSignConf + signKey <- signGetKey + let prv = getSignKey inp (signKey :: signKey) + let rawSig = getHashForSig tx btcCondScr idx btcSignFlag `HC.signMsg` prv + newSigData :: Tagged r newSigData + newSigData = mkSigData btcSigData (BtcSig rawSig btcSignFlag) + signPK = unTagged (signerPubKey btcCondScr :: Tagged newSigData PubKeyC) + realPK = HC.derivePubKey prv + retVal = Right $ mapSigData (const $ unTagged newSigData) inp + return $ if realPK == signPK + then retVal + else if doSignCheck + then Left $ SignKeyError idx (realPK `FoundButExpected` signPK) + else retVal + + +-- #################### +-- ### Verification ### + +verifyTx :: (SpendFulfillment ss r, SpendCondition r) => + BtcTx t r ss -> Either VerifyError () verifyTx tx@BtcTx{..} = if null verifyRes then Right () else Left $ SigVerifyFail $ map snd verifyRes where verifyRes = concatMap getErrors $ zipWith (verifyInput tx) [0..] (NE.toList btcIns) getErrors = filter ((== False) . fst) +-- TODO: fix SIG_SINGLE/SIG_NONE verify bug verifyInput :: forall r t ss. - (SpendFulfillment ss r, SpendCondition r, HasSpendCond r t) => - BtcTx t ss + (SpendFulfillment ss r, SpendCondition r) => + BtcTx t r ss -> Word32 - -> InputG t ss + -> InputG t r ss -> [(Bool, (Word32, PubKey, HC.Hash256, HC.Signature))] verifyInput tx idx MkInputG{..} = do - let redeemScr = getCond btcInType :: r - let getHash = getHashForSig tx redeemScr idx - let keySigL = rawSigs btcSigData redeemScr - let sigVerify (pk, MkBtcSig sig flag) = + let getHash = getHashForSig tx btcCondScr idx + let keySigL = rawSigs btcSigData btcCondScr + let sigVerify (pk, BtcSig sig flag) = ( HC.verifySig (getHash flag) sig pk , (idx, pk, getHash flag, sig) ) map sigVerify keySigL getHashForSig :: - SpendCondition r => BtcTx t a -> r -> Word32 -> HS.SigHash -> HC.Hash256 + SpendCondition r => BtcTx t r a -> r -> Word32 -> HS.SigHash -> HC.Hash256 getHashForSig tx rdmScr idx = HS.txSigHash (toUnsignedTx tx) (conditionScript rdmScr) (toInt idx) -txSize :: SignatureScript t ss => BtcTx t ss -> TxByteSize +txSize :: SignatureScript r ss t => BtcTx t r ss -> TxByteSize txSize = calcTxSize . toHaskoinTx mkRelativeFeeTxM - :: (Monad m, HasFee fee, SignatureScript t ss, HasSpendCond r t, SpendFulfillment ss r) - => fee -- ^Desired (per-byte) transaction fee - -> ( BtcAmount -> m (Either e (BtcTx t ss)) ) -- ^Produces desired Bitcoin tx with given fee - -> m (Either e (BtcTx t ss)) + :: (Monad m, HasFee fee, SignatureScript r ss t) + => fee -- ^ Desired transaction fee + -> ( BtcAmount -> m (Either e (BtcTx t r ss)) ) -- ^ Produces desired Bitcoin tx with given fee + -> m (Either e (BtcTx t r ss)) mkRelativeFeeTxM fee mkTxFunc = mkTxFunc (0 :: BtcAmount) >>= \txE -> case txE of Right tx -> mkTxSizeFee tx left -> return left where - mkTxSizeFee tx = mkTxFunc $ absoluteFee (txSize tx) fee + mkTxSizeFee tx = mkTxFunc $ absoluteFee (fromIntegral $ availableVal tx) (txSize tx) fee diff --git a/src/Bitcoin/SinglePair.hs b/src/Bitcoin/SinglePair.hs --- a/src/Bitcoin/SinglePair.hs +++ b/src/Bitcoin/SinglePair.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} module Bitcoin.SinglePair -( - module Bitcoin.SinglePair +( module Bitcoin.SinglePair , module X ) where @@ -18,7 +17,7 @@ {-# ANN module ("HLint: ignore Use isNothing"::String) #-} -instance (Show r, Show sd) => IsTxLike SigSinglePair r sd where +instance (Show r, Show sd) => IsTxLike SigSinglePair t r sd where toBtcTx SigSinglePair{..} = BtcTx 1 inputL [singleOutput] Nothing Nothing where inputL = singleInput NE.:| [] @@ -28,7 +27,7 @@ where input = head . NE.toList $ btcIns output = head btcOuts -mkSigSinglePair :: InputG r () -> BtcOut -> SigSinglePair r () +mkSigSinglePair :: InputG t r () -> BtcOut -> SigSinglePair t r () mkSigSinglePair pin out = SigSinglePair (adjustSignFlag pin) out where @@ -37,25 +36,25 @@ then HS.SigSingle True else HS.SigNone True -signPair :: ( Monad m, Show t - , TransformSigData BtcSig () r, SignatureScript t BtcSig - , SpendFulfillment BtcSig r, HasSpendCond r t ) => +signPair :: ( Monad m, Show r + , TransformSigData BtcSig () r --, SignatureScript t r BtcSig + , SpendFulfillment BtcSig r + ) => HC.PrvKeyC - -> SigSinglePair t () - -> m (Either BtcError (SigSinglePair t BtcSig)) + -> SigSinglePair t r () + -> m (Either BtcError (SigSinglePair t r BtcSig)) signPair prvKey sp@SigSinglePair{..} = - fmap fromBtcTx <$> signTx (const $ return prvKey) (toBtcTx sp) + return $ fromBtcTx <$> runSimple prvKey (signTx $ toBtcTx sp) singlePairVerifySig :: ( Show ss, Show t , SpendFulfillment ss r , SpendCondition r - , HasSpendCond r t ) => - SigSinglePair t ss -> Either VerifyError () + SigSinglePair t r ss -> Either VerifyError () singlePairVerifySig sp = verifyTx (toBtcTx sp) -toClientSignedTx :: Show t => NE.NonEmpty (SigSinglePair t BtcSig) -> BtcTx t BtcSig +toClientSignedTx :: Show r => NE.NonEmpty (SigSinglePair t r BtcSig) -> BtcTx t r BtcSig toClientSignedTx spL = foldr addInOut (toBtcTx $ NE.last spL) (NE.init spL) where addInOut SigSinglePair{..} tx@BtcTx{..} = tx { btcIns = singleInput NE.<| btcIns @@ -63,34 +62,58 @@ } -getSigData :: SigSinglePair t sd -> sd +getSigData :: SigSinglePair t r sd -> sd getSigData = btcSigData . singleInput -sigDataHash :: SigSinglePair t BtcSig -> HC.Hash256 -sigDataHash = hashSigData . getSigData - -pairRedeemScript :: HasSpendCond r t => SigSinglePair t a -> r -pairRedeemScript SigSinglePair{..} = inputCondScript singleInput +pairRedeemScript :: SigSinglePair t r a -> r +pairRedeemScript SigSinglePair{..} = btcCondScr singleInput -fundingValue :: SigSinglePair t BtcSig -> BtcAmount +fundingValue :: SigSinglePair t r a -> BtcAmount fundingValue SigSinglePair{..} = btcInValue singleInput -clientChangeVal :: SigSinglePair t BtcSig -> BtcAmount +clientChangeVal :: SigSinglePair t r a -> BtcAmount clientChangeVal SigSinglePair{..} = nonDusty (btcAmount singleOutput) -clientChangeAddr :: SigSinglePair t BtcSig -> HC.Address +resetClientChangeVal :: + HasConfDustLimit m + => SigSinglePair t r BtcSig + -> m (Either BtcError (SigSinglePair t r InvalidSig)) +resetClientChangeVal ssp@SigSinglePair{..} = + fmap (mapSigData fromBtcSig . mkNew) <$> mkNonDusty (fundingValue ssp) + where + mkNew fundVal = + ssp { singleOutput = + singleOutput { btcAmount = fundVal } + } + + +clientChangeAddr :: SigSinglePair t r a -> HC.Address clientChangeAddr SigSinglePair{..} = btcAddress singleOutput -clearSig :: SigSinglePair t BtcSig -> SigSinglePair t () -clearSig = spMapSigData $ const () +class SetClientChangeAddr (s :: * -> *) where + _setClientChangeAddr :: s BtcSig -> HC.Address -> s InvalidSig -spMapSigData :: (a -> b) -> SigSinglePair t a -> SigSinglePair t b -spMapSigData f sp@SigSinglePair{..} = sp { singleInput = mapSigData f singleInput } +instance SetClientChangeAddr (SigSinglePair t r) where + _setClientChangeAddr ssp@SigSinglePair{..} addr = + mapSigData fromBtcSig $ ssp { singleOutput = + singleOutput { btcAddress = addr } + } +clearSig :: SigSinglePair t r a -> SigSinglePair t r () +clearSig = mapSigData $ const () + -- | After the lockTime -- specified in the funding output in the blockchain -- -- has passed, the client/sender can redeem all sent funds. So we make sure -- this isn't possible before accepting a payment. -fundingIsLocked :: (Show t, Show sd, MonadTime m, HasLockTimeDate t) => SigSinglePair t sd -> m Bool -fundingIsLocked = allInputsLocked . toBtcTx - +fundingIsLocked :: + ( Show r + , Show sd + , MonadTime m + , HasLockTimeDate r + ) + => Seconds + -> SigSinglePair t r sd + -> m Bool +fundingIsLocked settlePeriodSeconds = + allInputsLocked settlePeriodSeconds . toBtcTx 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 @@ -1,14 +1,15 @@ {-# LANGUAGE DeriveGeneric, DeriveAnyClass, KindSignatures #-} module Bitcoin.SpendCond.Cond -( - module Bitcoin.SpendCond.Cond +( module Bitcoin.SpendCond.Cond , module Bitcoin.Types ) where import Bitcoin.Util +import Bitcoin.Internal.Util import Bitcoin.Types import Network.Haskoin.Script +import Data.Void import qualified Data.Serialize as Bin import qualified Data.Aeson.Types as JSON @@ -18,7 +19,7 @@ -- ### Input interface -- ##################### -- | Script that defines a condition to spend -class SpendCondition c where +class Show c => SpendCondition c where -- | The script will, depending on transaction type, -- be placed either in output, input or witness of transaction conditionScript :: c -> Script @@ -34,126 +35,137 @@ -- ### Output interface -- ###################### -- | Script we put in the output of a transaction -class ScriptPubKey c where - scriptPubKey :: c -> TxOutputScript +class ScriptPubKey c t where + scriptPubKey :: c -> TxOutputScript t -class SignatureScript c f where +class SignatureScript c f t where -- | The script we put inside a transaction input - inputScript :: f -> c -> TxInputScript + inputScript :: f -> c -> TxInputScript t -- | The script we put inside a transaction witness - witnessScript :: f -> c -> WitnessScript + witnessScript :: f -> c -> WitnessScript t -- | Pay to something -data Pay2 a = Pay2 a +newtype Pay2 a = Pay2 a 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, NFData) +--newtype Witness a = Witness a +-- deriving (Eq, Show, Typeable, Generic, JSON.ToJSON, JSON.FromJSON, Bin.Serialize, NFData) -- | Hash a 'SpendCondition' -data ScriptHash a = ScriptHash a +newtype ScriptHash a = ScriptHash a deriving (Eq, Show, Typeable, Generic, JSON.ToJSON, JSON.FromJSON, Bin.Serialize, NFData) --- | Wraps a 'SpendCondition' -data Cond a = Cond a +-- | Represents a 'SpendCondition' +data Cond = Cond deriving (Eq, Show, Typeable, Generic, JSON.ToJSON, JSON.FromJSON, Bin.Serialize, NFData) --- | Pay to script hash (P2SH) -type P2SH c = Pay2 (ScriptHash (Cond c)) --- | Pay to witness script hash (P2WSH) -type P2WSH c = Pay2 (Witness (Cond c)) --- | P2WSH inside P2SH (for compatibility with old wallet clients) -type P2SHWit c = Pay2 (ScriptHash (Witness (Cond c))) - - - -class IsWrapper c (wrap :: * -> *) where - unwrap :: wrap c -> c - -instance IsWrapper c Pay2 where unwrap (Pay2 c) = c -instance IsWrapper c Cond where unwrap (Cond c) = c -instance IsWrapper c Witness where unwrap (Witness c) = c -instance IsWrapper c ScriptHash where unwrap (ScriptHash c) = c +type P2S = Pay2 Cond +type P2SH = Pay2 (ScriptHash Cond) +---- | Pay to script (P2S) +--newtype P2Script = P2Script (Pay2 Cond) +---- | Pay to script hash (P2SH) +--newtype P2SH = P2SH (Pay2 (ScriptHash Cond)) +---- | Pay to witness script hash (P2WSH) +--newtype P2WSH = P2WSH (Pay2 (Witness Cond)) +---- | P2WSH inside P2SH (for compatibility with old wallet clients) +--newtype P2SHWit = P2SHWit (Pay2 (ScriptHash (Witness Cond))) -class HasSpendCond c ac | ac -> c where - getCond :: ac -> c - mkCond :: c -> ac +--mkP2sh :: c -> P2SH c +--mkP2sh = Pay2 . ScriptHash . Cond -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 +--class IsWrapper c (wrap :: * -> *) where +-- unwrap :: wrap c -> c +-- +--instance IsWrapper c Pay2 where unwrap (Pay2 c) = c +--instance IsWrapper c Cond where unwrap Cond = c +--instance IsWrapper c Witness where unwrap (Witness c) = c +--instance IsWrapper c ScriptHash where unwrap (ScriptHash c) = c -inputCondScript :: HasSpendCond r t => InputG t a -> r -inputCondScript MkInputG{..} = getCond btcInType +--class HasSpendCond c (ac :: * -> *) where +-- getCond :: ac c -> c +-- mkCond :: c -> ac c +-- +--instance HasSpendCond c P2Script where +-- getCond = unwrap . unwrap +-- mkCond = P2Script . Pay2 . Cond +--instance HasSpendCond c P2SH where +-- getCond = unwrap . unwrap . unwrap +-- mkCond = P2SH . Pay2 . ScriptHash . Cond +--instance HasSpendCond c P2WSH where +-- getCond = unwrap . unwrap . unwrap +-- mkCond = P2WSH . Pay2 . Witness . Cond +--instance HasSpendCond c P2SHWit where +-- getCond = unwrap . unwrap . unwrap . unwrap +-- mkCond = P2SHWit . Pay2 . ScriptHash . Witness . Cond +-- +--inputCondScript :: HasSpendCond r t => InputG t r a -> r +--inputCondScript MkInputG{..} = getCond btcInType -- ## ScriptPubKey -- ################# -instance SpendCondition c => ScriptPubKey (Pay2 (Cond c)) where - scriptPubKey (Pay2 (Cond c)) = mkScript $ +instance SpendCondition c => ScriptPubKey c P2S where + scriptPubKey c = mkScript $ conditionScript c -instance SpendCondition c => ScriptPubKey (Pay2 (ScriptHash (Cond c))) where - scriptPubKey (Pay2 (ScriptHash (Cond c))) = +instance SpendCondition c => ScriptPubKey c P2SH where + scriptPubKey c = p2shScriptPubKey (mkScript $ conditionScript c) -instance WitnessProgram wp => ScriptPubKey (Pay2 (Witness wp)) where - scriptPubKey (Pay2 (Witness wp)) = TxOutputScript +{- +instance -- WitnessProgram wp + SpendCondition c => ScriptPubKey c (Pay2 (Witness Cond)) where + scriptPubKey wp = TxOutputScript [ OP_0, opPushData $ witnessProgram wp ] -instance WitnessProgram wp => ScriptPubKey (Pay2 (ScriptHash (Witness wp))) where - scriptPubKey (Pay2 (ScriptHash (Witness wp))) = - p2shScriptPubKey $ scriptPubKey (Pay2 (Witness wp)) - +instance -- WitnessProgram wp + SpendCondition c => ScriptPubKey c (Pay2 (ScriptHash (Witness Cond))) where + scriptPubKey wp = + p2shScriptPubKey (scriptPubKey wp :: TxOutputScript (Pay2 (Witness Cond))) +-} -- ## SignatureScript -- #################### -- Pay to script -instance SpendFulfillment f c => SignatureScript (Pay2 (Cond c)) f where - inputScript ss (Pay2 (Cond c)) = mkScript $ +instance SpendFulfillment f c => SignatureScript c f P2S where + inputScript ss c = mkScript $ signatureScript ss c witnessScript _ _ = WitnessScript [] -- P2SH instance ( SpendCondition c, SpendFulfillment f c) - => SignatureScript (Pay2 (ScriptHash (Cond c))) f where + => SignatureScript c f P2SH where -- For P2SH inputScript, we add a push of the serialized conditionScript - inputScript ss (Pay2 (ScriptHash (Cond c))) = mkScript $ + inputScript ss c = mkScript $ signatureScript ss c <> Script [ opPush $ conditionScript c ] witnessScript _ _ = WitnessScript [] +{- -- P2WSH/P2WPKH -instance ( WitnessSig f wp - , WitnessProgram wp +instance ( SpendCondition c + , SpendFulfillment f c ) - => SignatureScript (Pay2 (Witness wp)) f where + => SignatureScript c f (Pay2 (Witness Cond)) where inputScript _ _ = TxInputScript [] - witnessScript ss (Pay2 (Witness wp)) = mkWitnessScript wp ss + witnessScript ss wp = mkWitnessScript wp ss -- P2WSH/P2WPKH inside P2SH -instance ( WitnessSig f wp - , WitnessProgram wp +instance ( SpendCondition c + , SpendFulfillment f c +-- , WitnessSig f wp (Pay2 (ScriptHash (Witness Cond))) +-- , WitnessProgram wp (Pay2 (ScriptHash (Witness Cond))) ) - => SignatureScript (Pay2 (ScriptHash (Witness wp))) f where - inputScript _ (Pay2 (ScriptHash (Witness wp))) = TxInputScript - [ opPush $ asScript $ scriptPubKey (Pay2 (Witness wp)) ] + => SignatureScript c f (Pay2 (ScriptHash (Witness Cond))) where + inputScript _ wp = TxInputScript + [ opPush $ asScript $ (scriptPubKey wp :: TxInputScript (Pay2 (Witness wp))) ] witnessScript ss (Pay2 (ScriptHash (Witness wp))) = mkWitnessScript wp ss - +-} -- Util -p2shScriptPubKey :: TxOutputScript -> TxOutputScript +p2shScriptPubKey :: TxOutputScript a -> TxOutputScript b p2shScriptPubKey s = TxOutputScript [ OP_HASH160, opPush $ hash160 (asScript s), OP_EQUAL ] @@ -174,43 +186,44 @@ signatureScript (SpendPKH sig) (PubkeyHash pk) = Script [ opPush sig, opPush pk ] rawSigs (SpendPKH sig) (PubkeyHash pk) = [(pk, sig)] -instance SignatureScript PubkeyHash SpendPKH where +instance SignatureScript PubkeyHash SpendPKH Void where inputScript s = mkScript . signatureScript s witnessScript _ _ = WitnessScript [] - +{- -- | A witness program is (currently) either a SHA256 hash of a script -- or RIPEMD160 hash of a compressed public key. -class WitnessProgram wp where - witnessProgram :: wp -> B.ByteString - redeemScript :: wp -> Script +class WitnessProgram wp t where + witnessProgram :: wp -> Tagged t B.ByteString + redeemScript :: wp -> Tagged t Script -- P2WSH witness program -instance SpendCondition c => WitnessProgram (Cond c) where - witnessProgram (Cond c) = Bin.encode $ hash256 (conditionScript c) +instance SpendCondition c => WitnessProgram c Cond where + witnessProgram c = Tagged $ Bin.encode $ hash256 (conditionScript c) redeemScript wp = - Script [ opPush $ Script [ OP_0, opPushData $ witnessProgram wp ] ] + Tagged $ Script [ opPush $ Script [ OP_0, opPushData $ unTagged (witnessProgram wp) ] ] -- P2WPKH witness program -instance WitnessProgram PubkeyHash where - witnessProgram (PubkeyHash pk) = Bin.encode $ hash160 pk - redeemScript _ = mempty +instance WitnessProgram PubkeyHash Void where + witnessProgram (PubkeyHash pk) = Tagged $ Bin.encode $ hash160 pk + redeemScript _ = Tagged mempty -class WitnessSig ws wp where - mkWitnessScript :: wp -> (ws -> WitnessScript) +class WitnessSig ws wp t where + mkWitnessScript :: wp -> (ws -> WitnessScript t) -- P2SH witness program -instance (SpendCondition c, SpendFulfillment f c) => WitnessSig f (Cond c) where +instance (SpendCondition c, SpendFulfillment f c) => WitnessSig f c Cond where -- Same as P2SH inputScript - mkWitnessScript (Cond c) f = mkScript . asScript $ - inputScript f (Pay2 (ScriptHash (Cond c))) + mkWitnessScript c f = mkScript . asScript $ + (inputScript f c :: TxInputScript (Pay2 (ScriptHash Cond))) -- P2WPKH witness program -instance WitnessSig SpendPKH PubkeyHash where +instance WitnessSig SpendPKH PubkeyHash Void where -- Same as P2PKH inputScript mkWitnessScript pkh sig = mkScript . asScript $ - inputScript sig (Pay2 (Cond pkh)) + (inputScript sig pkh :: TxInputScript (Pay2 Cond)) +-} diff --git a/src/Bitcoin/SpendCond/Spec.hs b/src/Bitcoin/SpendCond/Spec.hs deleted file mode 100644 --- a/src/Bitcoin/SpendCond/Spec.hs +++ /dev/null @@ -1,120 +0,0 @@ -module Bitcoin.SpendCond.Spec -( - spendCondSpec -) -where - -import Bitcoin.SpendCond.Cond -import Bitcoin.Util - -import Test.Hspec -import Network.Haskoin.Script -import qualified Network.Haskoin.Script as HS - - - -data TestCond = TestCond -- ^ Test condition script -data TestFulfill = TestFulfill -- ^ Test fulfillment/signature script - -instance SpendCondition TestCond where - conditionScript _ = Script [ opPushData "TEST_SCRIPT" ] -instance SpendFulfillment TestFulfill TestCond where - signatureScript _ _ = Script [ opPushData "TEST_SIG" ] - rawSigs = undefined - -testPubKey = mkDummyPubkey "0323dcd0a7481cb90e3583923701b14d0b6757ebd76bf5b49e696c61f193d7a489" -testSig = mkDummySig "304402204202cdb61cb702aa62de312a8e5eada817d90c4e26c8b696780b14d1576f204f02203c134d0acb057d917508ca9baab241a4f66ebea32f7acceeaf621a334927e17701" -testBtcSig = MkBtcSig testSig (HS.SigAll False) - -fulfill = TestFulfill -testPKHSig = SpendPKH testBtcSig - --- | For regular P2PKH we're using an actual condition/script, --- but for P2WPKH it's just a template that's --- handled as a special case by the script interpreter. -p2pkh = Pay2 $ Cond $ PubkeyHash testPubKey -p2wpkh = Pay2 $ Witness $ PubkeyHash testPubKey -p2wpkhINp2sh = Pay2 $ ScriptHash $ Witness $ PubkeyHash testPubKey - -p2sh = Pay2 $ ScriptHash $ Cond TestCond -p2wsh = Pay2 $ Witness $ Cond TestCond -p2wshINp2sh = Pay2 $ ScriptHash $ Witness $ Cond TestCond - - - -spendCondSpec :: IO () -spendCondSpec = hspec $ - describe "Transaction script & witness" $ do - describe "P2PKH has correct" $ do - it "scriptPubKey" $ scriptPubKey p2pkh `shouldBe` - TxOutputScript [ OP_DUP - , OP_HASH160 - , opPush (hash160 testPubKey) - , OP_EQUALVERIFY - , OP_CHECKSIG - ] - it "scriptSig" $ inputScript testPKHSig p2pkh `shouldBe` - TxInputScript [ opPush testBtcSig, opPush testPubKey ] - it "witness" $ witnessScript testPKHSig p2pkh `shouldBe` - WitnessScript mempty - - - describe "P2SH has correct" $ do - it "scriptPubKey" $ scriptPubKey p2sh `shouldBe` - TxOutputScript [ OP_HASH160 - , opPush $ hash160 (conditionScript TestCond) - , OP_EQUAL - ] - it "scriptSig" $ inputScript fulfill p2sh `shouldBe` - TxInputScript [ OP_PUSHDATA "TEST_SIG" OPCODE - , OP_PUSHDATA "\vTEST_SCRIPT" OPCODE - ] - it "witness" $ witnessScript fulfill p2sh `shouldBe` - WitnessScript mempty - - describe "P2WPKH has correct" $ do - it "scriptPubKey" $ scriptPubKey p2wpkh `shouldBe` - TxOutputScript [ OP_0 - , opPush (hash160 testPubKey) - ] - it "scriptSig" $ inputScript testPKHSig p2wpkh `shouldBe` - TxInputScript mempty - it "witness" $ witnessScript testPKHSig p2wpkh `shouldBe` - WitnessScript [ opPush testBtcSig, opPush testPubKey ] - - describe "P2WPKH in P2SH has correct" $ do - it "scriptPubKey" $ scriptPubKey p2wpkhINp2sh `shouldBe` - TxOutputScript [ OP_HASH160 - , OP_PUSHDATA "sA\SOH\aR\166\&1\196\182\178%\US\183[\177g^\158E\177" OPCODE - , OP_EQUAL - ] - it "scriptSig" $ inputScript testPKHSig p2wpkhINp2sh `shouldBe` - TxInputScript [ OP_PUSHDATA (serialize $ Script [ OP_0, opPush (hash160 testPubKey) ]) OPCODE ] - it "witness" $ witnessScript testPKHSig p2wpkhINp2sh `shouldBe` - WitnessScript [ opPush testBtcSig, opPush testPubKey ] - - describe "P2WSH has correct" $ do - it "scriptPubKey" $ scriptPubKey p2wsh `shouldBe` - TxOutputScript [ OP_0 - , opPush (hash256 $ conditionScript TestCond) - ] - it "scriptSig" $ inputScript fulfill p2wsh `shouldBe` - TxInputScript mempty - it "witness" $ witnessScript fulfill p2wsh `shouldBe` - WitnessScript [ OP_PUSHDATA "TEST_SIG" OPCODE - , OP_PUSHDATA "\vTEST_SCRIPT" OPCODE - ] - - describe "P2WSH in P2SH has correct" $ do - it "scriptPubKey" $ scriptPubKey p2wshINp2sh `shouldBe` - TxOutputScript [ OP_HASH160 - , OP_PUSHDATA "tq\233\219J\199\255\192C\177n\"\156U\171\233\151\206\188O" OPCODE - , OP_EQUAL - ] - it "scriptSig" $ inputScript fulfill p2wshINp2sh `shouldBe` - TxInputScript [ OP_PUSHDATA (serialize $ Script [ OP_0, opPush (hash256 $ conditionScript TestCond) ]) OPCODE ] - it "witness" $ witnessScript fulfill p2wshINp2sh `shouldBe` - WitnessScript [ OP_PUSHDATA "TEST_SIG" OPCODE - , OP_PUSHDATA "\vTEST_SCRIPT" OPCODE - ] - diff --git a/src/Bitcoin/SpendCond/Util.hs b/src/Bitcoin/SpendCond/Util.hs --- a/src/Bitcoin/SpendCond/Util.hs +++ b/src/Bitcoin/SpendCond/Util.hs @@ -1,23 +1,78 @@ -module Bitcoin.SpendCond.Util where +{-# LANGUAGE DeriveAnyClass #-} +module Bitcoin.SpendCond.Util +( getPrevIns +, singlePrevIn +, PickOutError(..) +, module Bitcoin.Util +) +where import Bitcoin.Util +import Bitcoin.Internal.Util import qualified Network.Haskoin.Transaction as HT import Bitcoin.SpendCond.Cond +import Data.Word (Word32) +import Debug.Trace --- | Create inputs from outputs that pay to the given redeemScript -getPrevIn :: forall r t. (SpendCondition r, HasSpendCond r t) => +-- | Create inputs that redeem outputs paying to the given (P2SH) redeemScript +getPrevIns :: SpendCondition r => HT.Tx -> r - -> [InputG t ()] -getPrevIn tx rdmScr = - map (mapInputType mkCond . mkInput) $ catMaybes $ - zipWith checkOut [0..] (HT.txOut tx) + -> [InputG P2SH r ()] +getPrevIns tx rdmScr = + map mkInput . catMaybes . checkOuts $ libCheckOut 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)) + checkOuts f = zipWith f [0..] (HT.txOut tx) + -- implementation: Bitcoin.SpendCond + libCheckOut idx out = + if HT.scriptOutput out == encode (asScript (scriptPubKey rdmScr :: TxOutputScript P2SH)) + then Just (idx, HT.outValue out) + else Nothing + -- implementation: Network.Haskoin + haskoinCheckOut idx out = + either (const Nothing) (_checkMatch idx) + (decodeScriptHash (HT.scriptOutput out) >>= \sh -> Right (sh, HT.outValue out)) + _checkMatch idx (hash,val) = if hash == _scrHash then Just (idx,val) else Nothing + _scrHash = hash160 $ conditionScript rdmScr + +singlePrevIn :: + ( Show r + , SpendCondition r + ) + => HT.Tx + -> r + -> Word32 + -> Either (PickOutError r) (InputG P2SH r ()) +singlePrevIn tx scr i = + let inputOfInterest = (== i) . HT.outPointIndex . btcPrevOut + pickOut = + case filter inputOfInterest $ getPrevIns tx scr of + [] -> Left $ IrrelevantOutput i (HT.txHash tx) scr + [inp] -> Right inp + x -> error $ "getPrevIns: multiple inputs with same prevOutIndex: " ++ show x + in + if i >= fromIntegral (length $ HT.txOut tx) + then Left $ NoSuchOutput i (HT.txHash tx) + else pickOut + + +data PickOutError r + = NoSuchOutput Word32 HT.TxHash + | IrrelevantOutput Word32 HT.TxHash r + deriving (Eq, Generic, NFData, ToJSON, FromJSON, Serialize) + +instance SpendCondition r => Show (PickOutError r) where + show (NoSuchOutput i h) = unwords + [ "no such output:" + , showOut h i + ] + show (IrrelevantOutput i h scr) = unwords + [ showOut h i + , "doesn't pay to spendCondition" + , show scr + ] + +showOut h i = show i ++ ":" ++ cs (encode h) diff --git a/src/Bitcoin/Tx.hs b/src/Bitcoin/Tx.hs --- a/src/Bitcoin/Tx.hs +++ b/src/Bitcoin/Tx.hs @@ -1,17 +1,18 @@ module Bitcoin.Tx where import Bitcoin.Types -import PaymentChannel.Internal.Util import Bitcoin.LockTime.Util import qualified Data.List.NonEmpty as NE import Control.Monad.Time -allInputsLocked :: (MonadTime m, HasLockTimeDate inType) => BtcTx inType a -> m Bool -allInputsLocked BtcTx{..} = do - isLockedLst <- mapM (isLocked . btcInType) (NE.toList btcIns) +allInputsLocked :: + ( MonadTime m + , HasLockTimeDate r + ) + => Seconds -- ^ Lock expires this many seconds before actual expiration date + -> BtcTx inType r a + -> m Bool +allInputsLocked settlePeriodSeconds BtcTx{..} = do + isLockedLst <- mapM (isLocked settlePeriodSeconds . btcCondScr) (NE.toList btcIns) return $ all (== True) isLockedLst - - - - diff --git a/src/Bitcoin/Types.hs b/src/Bitcoin/Types.hs --- a/src/Bitcoin/Types.hs +++ b/src/Bitcoin/Types.hs @@ -1,272 +1,8 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE KindSignatures, DeriveAnyClass, DeriveFunctor #-} module Bitcoin.Types -( - module Bitcoin.Types -, module X +( module X ) - where -import Bitcoin.Orphans as X () -import Bitcoin.Dust as X -import Bitcoin.Amount as X -import Bitcoin.Fee as X -import Bitcoin.Util as X -import Bitcoin.Error as X -import PaymentChannel.Internal.Crypto.PubKey as X -import Bitcoin.LockTime.Types as X - -import qualified Data.List.NonEmpty as NE -import qualified Data.Serialize as Bin -import qualified Data.Aeson.Types as JSON -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 - { btcVer :: Word32 - , btcIns :: NE.NonEmpty (InputG inType sigData) - , btcOuts :: [BtcOut] - , btcChgOut :: Maybe ChangeOut - , btcLock :: Maybe LockTimeDate - } deriving (Eq, Show, Typeable, Generic, JSON.ToJSON, JSON.FromJSON, NFData) - - --- | Generic input -data InputG inType sigData = - MkInputG - { btcPrevOut :: HT.OutPoint -- ^ The output we're redeeming - , btcInValue :: BtcAmount -- ^ Value of output that is redeemed - , btcSigData :: sigData -- ^ The type of the signature data, eg. '()' for unsigned - , btcInType :: inType - , 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, NFData) - --- | Generic output -data OutputG outType = - MkOutputG - { btcOutAmount :: BtcAmount - , btcOutType :: outType - } 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, 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) -- --- rather than all tx inputs/outputs -- and that additional inputs can be added --- later to the tx (ANYONECANPAY). --- As a special case, if the output amount equals zero, the input is signed --- with SIG_NONE|ANYONECANPAY and the output removed, resulting in all value --- from the funding output being transferred to the server. -data SigSinglePair t sd = SigSinglePair - { singleInput :: InputG t sd - , singleOutput :: BtcOut - } 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) - where sigFlag = bsSigFlag . btcSigData . singleInput - -data ChangeOut = ChangeOut - { btcChangeAddr :: HC.Address - , btcTxFee :: SatoshisPerByte - , btcDustPolicy :: DustPolicy - -- | For internal use. - , btcAbsFee_ :: BtcAmount - } 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, NFData) - -type UnsignedBtcTx t = BtcTx t () -type UnsignedBtcIn t = InputG t () - --- | ECDSA signature plus sig hash flag -data BtcSig = MkBtcSig - { bsSig :: HC.Signature - , bsSigFlag :: HS.SigHash - } deriving (Eq, Show, Typeable, Generic, Bin.Serialize, NFData) - -instance ToJSON BtcSig where - toJSON = object . paySigKV - where paySigKV (MkBtcSig sig flag) = - [ "signature_data" .= String (serHex sig) - , "sighash_flag" .= String (serHex flag) ] -instance FromJSON BtcSig where - parseJSON = withObject "BtcSig" $ \o -> - MkBtcSig <$> - (o .: "signature_data" >>= withText "SigDataHex" deserHex) <*> - (o .: "sighash_flag" >>= withText "HashFlagHex" deserHex) - - - - - -instance Eq (IgnoreSigData BtcSig) where - IgnoreSigData (MkBtcSig _ flag1) == IgnoreSigData (MkBtcSig _ flag2) = - flag1 == flag2 - -data AlwaysEq a = AlwaysEq a -instance Eq (AlwaysEq a) where _ == _ = True -data IgnoreSigData a = IgnoreSigData a deriving (Show, Functor) - - -instance Eq inType => Eq (IgnoreSigData (BtcTx inType BtcSig)) where - IgnoreSigData tx1 == IgnoreSigData tx2 = - txMapSigData IgnoreSigData tx1 == txMapSigData IgnoreSigData tx2 - - --- | Types that can be converted to/from a 'BtcTx', --- parametized over redeemScript and signature data type. -class IsTxLike (txLike :: * -> * -> *) r sd where - toBtcTx :: txLike r sd -> BtcTx r sd - fromBtcTx :: BtcTx r sd -> txLike r sd - -instance IsTxLike BtcTx r ss where - toBtcTx = id - fromBtcTx = id - -data VerifyError = - SigVerifyFail [(Word32,HC.PubKeyC,HC.Hash256,HC.Signature)] - deriving (Eq, Show, Typeable, Generic) -- , Bin.Serialize, JSON.ToJSON, JSON.FromJSON, NFData) - --- Defaults -defaultTxVersion :: Word32 -defaultTxVersion = 1 - -defaultSigHashFlag :: HS.SigHash -defaultSigHashFlag = HS.SigAll False - - --- Simple constructors -mkBtcTx :: NE.NonEmpty (InputG t sd) -> [BtcOut] -> BtcTx t sd -mkBtcTx ins outs = BtcTx defaultTxVersion ins outs Nothing Nothing - -mkNoSigTxIn :: HT.OutPoint -> BtcAmount -> r -> UnsignedBtcIn r -mkNoSigTxIn op val t = MkInputG op val () t maxBound defaultSigHashFlag 0 - -mkBtcOut :: HC.Address -> NonDusty BtcAmount -> BtcOut -mkBtcOut = BtcOut - -mkChangeOut :: HC.Address -> SatoshisPerByte -> DustPolicy -> ChangeOut -mkChangeOut chgAdr fee dp = ChangeOut chgAdr fee dp 0 - -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 } - where mapIn = mapSigData f - -setSequence :: Word32 -> InputG t a -> InputG t a -setSequence s bin = bin { btcSequence = s } - -availableVal :: BtcTx r a -> Int64 -availableVal BtcTx{..} = - fromIntegral inVal - fromIntegral outVal - where - inVal = sum . NE.toList $ NE.map btcInValue btcIns - outVal = sum $ map (nonDusty . btcAmount) btcOuts - - - -setSignFlag :: HS.SigHash -> InputG t a -> InputG t a -setSignFlag sh inp = inp { btcSignFlag = sh } - -setLockTime :: LockTimeDate -> BtcTx r a -> BtcTx r a -setLockTime lt tx = tx { btcLock = Just lt } - -setChangeOut :: ChangeOut -> BtcTx r a -> BtcTx r a -setChangeOut co tx = tx { btcChgOut = Just co } - -disableLockTime :: BtcTx r a -> BtcTx r a -disableLockTime tx = tx { btcLock = Nothing } - -setKeyIndex :: KeyDeriveIndex -> InputG t a -> InputG t a -setKeyIndex kdi bin = bin { btcKeyIndex = kdi } - -setFee :: BtcAmount -> ChangeOut -> ChangeOut -setFee fee co = co { btcAbsFee_ = fee } - -setTxRawFee :: BtcAmount -> BtcTx r a -> BtcTx r a -setTxRawFee fee tx@BtcTx{..} = tx { btcChgOut = setFee fee <$> btcChgOut } - - --- Util -unsafeCastNE :: [a] -> NE.NonEmpty a -unsafeCastNE = fromMaybe (error "you promised this was a non-empty list") . NE.nonEmpty - - - - --- Conversion - -instance (Bin.Serialize t, Bin.Serialize sd) => Bin.Serialize (BtcTx t sd) where - put BtcTx{..} = - put btcVer - >> put (NE.toList btcIns) - >> put btcOuts - >> put btcChgOut - >> put btcLock - get = BtcTx - <$> get - <*> fmap unsafeCastNE get - <*> get - <*> get - <*> get - - --- Script types -newtype TxOutputScript = TxOutputScript [HS.ScriptOp] deriving Eq -newtype TxInputScript = TxInputScript [HS.ScriptOp] deriving Eq -newtype WitnessScript = WitnessScript [HS.ScriptOp] deriving Eq -class IsScript a where - mkScript :: HS.Script -> a - asScript :: a -> HS.Script -instance IsScript TxOutputScript where - mkScript (HS.Script ops) = TxOutputScript ops - asScript (TxOutputScript ops) = HS.Script ops -instance IsScript TxInputScript where - mkScript (HS.Script ops) = TxInputScript ops - asScript (TxInputScript ops) = HS.Script ops -instance IsScript WitnessScript where - mkScript (HS.Script ops) = WitnessScript ops - asScript (WitnessScript ops) = HS.Script ops -instance Show TxOutputScript where - show (TxOutputScript ops) = - "scriptPubKey: " ++ articulate ops -instance Show TxInputScript where - show (TxInputScript ops) = - "scriptSig: " ++ articulate ops -instance Show WitnessScript where - show (WitnessScript ops) = - "witness: " ++ articulate ops - -articulate :: forall a. Show a => [a] -> String -articulate ops = if null ops then "(empty)" else unwords (map show ops) - - -type PubKey = HC.PubKeyC - - -hashSigData :: BtcSig -> HC.Hash256 -hashSigData MkBtcSig{..} = HC.hash256 (Bin.encode bsSig) - +import Bitcoin.Types.Tx as X +import Bitcoin.BIP32 as X +import Bitcoin.Types.ExpectFail as X diff --git a/src/Bitcoin/Types/ExpectFail.hs b/src/Bitcoin/Types/ExpectFail.hs new file mode 100644 --- /dev/null +++ b/src/Bitcoin/Types/ExpectFail.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} + +module Bitcoin.Types.ExpectFail where + +import Bitcoin.Internal.Types + +data ExpectFail a + = a `FoundButExpected` a + deriving (Eq, Generic, NFData, ToJSON, FromJSON, Serialize) + +instance Show a => Show (ExpectFail a) where + show (found `FoundButExpected` expec) = unwords + ["found:", show found ++ ",", "but expected:", show expec] diff --git a/src/Bitcoin/Types/Tx.hs b/src/Bitcoin/Types/Tx.hs new file mode 100644 --- /dev/null +++ b/src/Bitcoin/Types/Tx.hs @@ -0,0 +1,323 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures, DeriveAnyClass, DeriveFunctor #-} +module Bitcoin.Types.Tx +( module Bitcoin.Types.Tx +, module X +, Default(..) +) + +where + +import Bitcoin.Internal.Orphans as X () +import Bitcoin.Dust as X +import Bitcoin.Amount as X +import Bitcoin.Fee as X +import Bitcoin.Error as X +import Bitcoin.LockTime.Types as X +--import Bitcoin.BIP32 +--import Bitcoin.Util +import Bitcoin.Internal.Util + +import qualified Data.List.NonEmpty as NE +import qualified Data.Serialize as Bin +--import qualified Data.Serialize.Get as BinGet +import qualified Data.Aeson.Types as JSON +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) +import Data.Default.Class (Default(..)) + + +data BtcTx inType condScr sigData = BtcTx + { btcVer :: Word32 + , btcIns :: NE.NonEmpty (InputG inType condScr sigData) + , btcOuts :: [BtcOut] + , btcChgOut :: Maybe ChangeOut + , btcLock :: Maybe LockTimeDate + } deriving (Eq, Show, Typeable, Generic, JSON.ToJSON, JSON.FromJSON, NFData) + +-- | Generic input +data InputG inType condScr sigData = + MkInputG + { btcPrevOut :: HT.OutPoint + -- ^ The output we're redeeming + , btcInValue :: BtcAmount + -- ^ Value of output that is redeemed + , btcSigData :: sigData + -- ^ The type of the signature data, eg. '()' for unsigned + , btcCondScr :: condScr + -- ^ ConditionScript type; represents payment channel contract. + -- 'inType' determines where this is located in the Bitcoin transaction + -- (redeeming input or paying output) + , 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 (Show, Typeable, Generic, Bin.Serialize, JSON.ToJSON, JSON.FromJSON, NFData) + +-- | Generic output +data OutputG outType condScr = + MkOutputG + { btcOutAmount :: BtcAmount + , btcOutCond :: condScr + } deriving (Eq, Show, Typeable, Generic, Bin.Serialize, JSON.ToJSON, JSON.FromJSON, NFData) + +data BtcOut = BtcOut + { btcAddress :: HC.Address + , btcAmount :: NonDustyAmount + } 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) -- +-- rather than all tx inputs/outputs -- and that additional inputs can be added +-- later to the tx (ANYONECANPAY). +-- As a special case, if the output amount equals zero, the input is signed +-- with SIG_NONE|ANYONECANPAY and the output removed, resulting in all value +-- from the funding output being transferred to the server. +data SigSinglePair t r sd = SigSinglePair + { singleInput :: InputG t r sd + , singleOutput :: BtcOut + } deriving (Eq, Show, Typeable, Generic, Bin.Serialize, JSON.ToJSON, JSON.FromJSON, NFData) + +instance (Eq condScr, Eq sigData) => Eq (InputG inType condScr sigData) where + (MkInputG prevOut1 inVal1 sigData1 condScr1 seq1 _) == + (MkInputG prevOut2 inVal2 sigData2 condScr2 seq2 _) = + prevOut1 == prevOut2 + && inVal1 == inVal2 + && sigData1 == sigData2 + && condScr1 == condScr2 + && seq1 == seq2 + -- Ignore sign flag + +instance Eq r => Ord (SigSinglePair t r BtcSig) where + compare a b = compare (sigFlag a) (sigFlag b) + where sigFlag = bsSigFlag . btcSigData . singleInput + +data ChangeOut = ChangeOut + { btcChangeAddr :: HC.Address + , btcTxFee :: TxFee + , btcDustPolicy :: DustPolicy + } deriving (Eq, Show, Typeable, Generic, Bin.Serialize, JSON.ToJSON, JSON.FromJSON, NFData) + + +data TxFee + = AbsoluteFee BtcAmount + | RelativeFee SatoshisPerByte + deriving (Eq, Show, Typeable, Generic, Bin.Serialize, JSON.ToJSON, JSON.FromJSON, NFData) + +absOrRelFee :: (BtcAmount -> a) -> (SatoshisPerByte -> a) -> TxFee -> a +absOrRelFee fAbs _ (AbsoluteFee val) = fAbs val +absOrRelFee _ fRel (RelativeFee spb) = fRel spb + +data DustPolicy = KeepDust | DropDust + deriving (Eq, Show, Typeable, Generic, Bin.Serialize, JSON.ToJSON, JSON.FromJSON, NFData) + +instance Default DustPolicy where def = DropDust + +type UnsignedBtcTx t r = BtcTx t r () +type UnsignedBtcIn t r = InputG t r () + +-- | ECDSA signature plus sig hash flag +data BtcSig = BtcSig + { bsSig :: HC.Signature + , bsSigFlag :: HS.SigHash + } deriving (Eq, Show, Typeable, Generic, Bin.Serialize, NFData) + +instance ToJSON BtcSig where + toJSON = object . paySigKV + where paySigKV (BtcSig sig flag) = + [ "signature_data" .= String (serHex sig) + , "sighash_flag" .= String (serHex flag) ] +instance FromJSON BtcSig where + parseJSON = withObject "BtcSig" $ \o -> + BtcSig <$> + (o .: "signature_data" >>= withText "SigDataHex" deserHex) <*> + (o .: "sighash_flag" >>= withText "HashFlagHex" deserHex) + +newtype InvalidSig = MkInvalidSig HS.SigHash + deriving (Eq, Show, Typeable, Generic, Bin.Serialize, NFData) + +fromBtcSig :: BtcSig -> InvalidSig +fromBtcSig = MkInvalidSig . bsSigFlag + + +-- -- Ignore signFlags and keyIndex (metadata) +--instance (Eq r, Eq sd) => Eq (InputG typ r sd) where +-- (MkInputG po1 inv1 sd1 r1 seq1) == (MkInputG po2 inv2 sd2 r2 seq2) = +-- po1 == po2 && inv1 == inv2 && sd1 == sd2 && r1 == r2 && seq1 == seq2 + +instance Eq (IgnoreSigData BtcSig) where + IgnoreSigData (BtcSig _ flag1) == IgnoreSigData (BtcSig _ flag2) = + flag1 == flag2 + +newtype AlwaysEq a = AlwaysEq a +instance Eq (AlwaysEq a) where _ == _ = True +newtype IgnoreSigData a = IgnoreSigData a deriving (Show, Functor) + + +instance Eq rdmScr => Eq (IgnoreSigData (BtcTx inType rdmScr BtcSig)) where + IgnoreSigData tx1 == IgnoreSigData tx2 = + mapSigData IgnoreSigData tx1 == mapSigData IgnoreSigData tx2 + + +-- | Types that can be converted to/from a 'BtcTx', +-- parametized over redeemScript and signature data type. +class IsTxLike (txLike :: * -> * -> * -> *) t r sd where + toBtcTx :: txLike t r sd -> BtcTx t r sd + fromBtcTx :: BtcTx t r sd -> txLike t r sd + +instance IsTxLike BtcTx t r ss where + toBtcTx = id + fromBtcTx = id + +newtype VerifyError = + SigVerifyFail [(Word32,HC.PubKeyC,HC.Hash256,HC.Signature)] + deriving (Eq, Show, Typeable, Generic) -- , Bin.Serialize, JSON.ToJSON, JSON.FromJSON, NFData) + +-- Defaults +defaultTxVersion :: Word32 +defaultTxVersion = 1 + +defaultSigHashFlag :: HS.SigHash +defaultSigHashFlag = HS.SigAll False + + +-- Simple constructors +mkBtcTx :: NE.NonEmpty (InputG t r sd) -> [BtcOut] -> BtcTx t r sd +mkBtcTx ins outs = BtcTx defaultTxVersion ins outs Nothing Nothing + +mkNoSigTxIn :: HT.OutPoint -> BtcAmount -> r -> UnsignedBtcIn t r +mkNoSigTxIn op val t = MkInputG op val () t maxBound defaultSigHashFlag + +mkBtcOut :: HC.Address -> NonDustyAmount -> BtcOut +mkBtcOut = BtcOut + +class HasFee fee => ChangeOutFee fee where + mkChangeOut :: HC.Address -> fee -> DustPolicy -> ChangeOut + +instance ChangeOutFee SatoshisPerByte where + mkChangeOut chgAdr sbp = ChangeOut chgAdr (RelativeFee sbp) + +instance ChangeOutFee BtcAmount where + mkChangeOut chgAdr val = ChangeOut chgAdr (AbsoluteFee val) + +txAddOuts :: [BtcOut] -> BtcTx t r sd -> BtcTx t r sd +txAddOuts outs tx = tx { btcOuts = btcOuts tx ++ outs } + + +-- Util +class HasSigData (t :: * -> *) where + mapSigData :: (a -> b) -> t a -> t b + +instance HasSigData (InputG t r) where + mapSigData f bin = bin { btcSigData = f $ btcSigData bin } + +--mapInputType :: (ta -> tb) -> InputG ta r a -> InputG tb r a +--mapInputType f bin = bin { btcInType = f $ btcInType bin } + +instance HasSigData (BtcTx t r) where + mapSigData f tx@BtcTx{..} = + tx { btcIns = NE.map mapIn btcIns } + where mapIn = mapSigData f + +instance HasSigData (SigSinglePair t r) where + mapSigData f sp@SigSinglePair{..} = sp { singleInput = mapSigData f singleInput } + + +setSequence :: Word32 -> InputG t r a -> InputG t r a +setSequence s bin = bin { btcSequence = s } + +availableVal :: BtcTx t r sd -> Int64 +availableVal BtcTx{..} = + fromIntegral inVal - fromIntegral outVal + where + inVal = sum . NE.toList $ NE.map btcInValue btcIns + outVal = sum $ map (nonDusty . btcAmount) btcOuts + + +setSignFlag :: HS.SigHash -> InputG t r a -> InputG t r a +setSignFlag sh inp = inp { btcSignFlag = sh } + +setLockTime :: LockTimeDate -> BtcTx t r sd -> BtcTx t r sd +setLockTime lt tx = tx { btcLock = Just lt } + +setChangeOut :: ChangeOut -> BtcTx t r sd -> BtcTx t r sd +setChangeOut co tx = tx { btcChgOut = Just co } + +disableLockTime :: BtcTx t r sd -> BtcTx t r sd +disableLockTime tx = tx { btcLock = Nothing } + +setAbsFee :: BtcAmount -> ChangeOut -> ChangeOut +setAbsFee fee co = co { btcTxFee = AbsoluteFee fee } + +setTxRawFee :: BtcAmount -> BtcTx t r sd -> BtcTx t r sd +setTxRawFee fee tx@BtcTx{..} = tx { btcChgOut = setAbsFee fee <$> btcChgOut } + + +-- Util +unsafeCastNE :: [a] -> NE.NonEmpty a +unsafeCastNE = fromMaybe (error "you promised this was a non-empty list") . NE.nonEmpty + + + +-- Conversion + +instance (Bin.Serialize r, Bin.Serialize sd) => Bin.Serialize (BtcTx t r sd) where + put BtcTx{..} = + put btcVer + >> put (NE.toList btcIns) + >> put btcOuts + >> put btcChgOut + >> put btcLock + get = BtcTx + <$> get + <*> fmap unsafeCastNE get + <*> get + <*> get + <*> get + + +-- Script types +newtype TxOutputScript t = TxOutputScript [HS.ScriptOp] deriving Eq +newtype TxInputScript t = TxInputScript [HS.ScriptOp] deriving Eq +newtype WitnessScript t = WitnessScript [HS.ScriptOp] deriving Eq + +class IsScript a where + mkScript :: HS.Script -> a + asScript :: a -> HS.Script + +instance IsScript (TxOutputScript t) where + mkScript (HS.Script ops) = TxOutputScript ops + asScript (TxOutputScript ops) = HS.Script ops + +instance IsScript (TxInputScript t) where + mkScript (HS.Script ops) = TxInputScript ops + asScript (TxInputScript ops) = HS.Script ops + +instance IsScript (WitnessScript t) where + mkScript (HS.Script ops) = WitnessScript ops + asScript (WitnessScript ops) = HS.Script ops + +instance Show (TxOutputScript t) where + show (TxOutputScript ops) = + "scriptPubKey: " ++ articulate ops +instance Show (TxInputScript t) where + show (TxInputScript ops) = + "scriptSig: " ++ articulate ops +instance Show (WitnessScript t) where + show (WitnessScript ops) = + "witness: " ++ articulate ops + +articulate :: forall a. Show a => [a] -> String +articulate ops = if null ops then "(empty)" else unwords (map show ops) + + +type PubKey = HC.PubKeyC + + + diff --git a/src/Bitcoin/Util.hs b/src/Bitcoin/Util.hs --- a/src/Bitcoin/Util.hs +++ b/src/Bitcoin/Util.hs @@ -1,12 +1,7 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Bitcoin.Util -( - module Bitcoin.Util -, module PaymentChannel.Internal.Util -) -where +{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +module Bitcoin.Util where -import PaymentChannel.Internal.Util +import Bitcoin.Internal.Util import Data.Word (Word32) import Data.String (fromString) @@ -28,21 +23,21 @@ HS.Script $ scr1 `mappend` scr2 - -- | Serialize NonEmpty list of "script witnesses". -- A transaction with no witnesses should use the old tx serialization format, hence the non-empty list. -- (https://github.com/bitcoin/bips/blob/master/bip-0144.mediawiki#Serialization) serTxWitness :: NE.NonEmpty HS.Script -> B.ByteString serTxWitness = NE.head . NE.scanr foldScript B.empty where - foldScript scr bsAccum = serScript scr <> bsAccum + foldScript scr !bsAccum = serScript scr <> bsAccum serScript scr = Bin.encode (HN.VarInt $ scrLen scr) <> Bin.encode scr scrLen (HS.Script ops) = fromIntegral $ length ops calcTxSize :: HT.Tx -> Word calcTxSize = fromIntegral . B.length . Bin.encode -dummyHash256 = fromString "3d96c573baf8f782e5f5f33dc8ce3c5bae654cbc888e9a3bbb8185a75febfd76" :: HC.Hash256 +dummyHash256 :: HC.Hash256 +dummyHash256 = fromString "0000000000000000000000000000000000000000000000000000000000000000" hash256 :: Bin.Serialize a => a -> HC.Hash256 hash256 = HC.hash256 . serialize diff --git a/src/PaymentChannel.hs b/src/PaymentChannel.hs --- a/src/PaymentChannel.hs +++ b/src/PaymentChannel.hs @@ -46,8 +46,7 @@ The receiver will now create its own channel state object, 'ServerPayChan', using 'channelFromInitialPayment'. - 'channelFromInitialPayment' takes the same 'ChanParams' and 'FundingTxInfo' - as was provided by the sender, and, in addition, the first channel 'Payment', received from the sender. + 'channelFromInitialPayment' takes [TODO]. Now the payment channel is open and ready for transmitting value. A new 'Payment' is created by the sender with 'createPayment', which yields a new payment, that increases the total value transmitted @@ -96,198 +95,46 @@ -} module PaymentChannel -( - -- *Initialization +( -- *Initialization + hasMinimumDuration - -- **Funding - getFundingAddress, +-- **Funding +, getFundingAddress +, validFundingInfo - -- **State creation - channelWithInitialPayment, - channelFromInitialPayment, +-- **State creation +, channelWithInitialPayment +, channelFromInitialPayment +, setMetadata - -- *Payment - createPayment, cappedCreatePayment, - acceptPayment, +-- *Payment +, createPayment, createPaymentCapped, Capped(..) +, acceptPayment +, ClosedServerChanX, getClosedState - -- *Settlement --- acceptClosingPayment, - getSettlementBitcoinTx, - getRefundBitcoinTx, +-- *Settlement +, getRefundBitcoinTx +, createClosingPayment +, acceptClosingPayment +, getSettlementBitcoinTx +, closedGetSettlementTx +, DustPolicy(..) +, ChangeOutFee +, RefundTx +, SettleTx - -- *Types - module PaymentChannel.Types +-- *Types +, module PaymentChannel.Types + + -- *RESTful Bitcoin Payment Channel Protocol +, module PaymentChannel.RBPCP.Parse ) where -import PaymentChannel.Internal.Payment - -import PaymentChannel.Internal.Receiver.Util - -import PaymentChannel.Internal.Util -import PaymentChannel.Internal.Error -import qualified PaymentChannel.Internal.Receiver.Util as S -import PaymentChannel.Internal.Metadata.Util -import PaymentChannel.Internal.Settlement (getSignedSettlementTx) -import PaymentChannel.Internal.Refund (mkRefundTx) - -import PaymentChannel.Util (getFundingAddress) import PaymentChannel.Types -import Control.Monad.Time - -import qualified Network.Haskoin.Crypto as HC -import qualified Network.Haskoin.Transaction as HT -import Data.Time.Clock (UTCTime(..)) -import Data.Time.Calendar (Day(..)) - -import Bitcoin.Compare - - -channelWithInitialPayment :: Monad m => - HC.PrvKeyC - -- ^ Used to sign payments from client - -> ChanParams - -- ^ Specifies channel sender, receiver, and expiration date - -> FundingTxInfo - -- ^ Holds information about the Bitcoin transaction used to fund the channel - -> HC.Address - -- ^ Client change address - -> BtcAmount - -- ^ Value of initial channel payment. This payment is sent to the receiver - -- in the initial handshake that opens the channel. Can be zero, in which - -- case the payment simply acts as a proof that the client owns the private - -- key whose corresponding public key is in 'ChanParams'. - -> m (Either BtcError (ClientPayChanI BtcSig, SignedPayment)) - -- ^ Client state and first payment. Error if the channel funding value - -- can't cover the specified payment value. -channelWithInitialPayment prvKey cp fundInf sendAddr payVal = - let mkPayChanState sp = MkPayChanState sp (sigDataHash sp) - mkClientChan sp = (MkClientPayChan (mkPayChanState sp) prvKey, sp) - in - fmap mkClientChan <$> createPaymentOfValue - prvKey (mkUnsignedPayment cp fundInf sendAddr) payVal - --- |Create new payment of specified value, along with updated state containing this payment. -createPayment :: Monad m => - ClientPayChanI BtcSig - -- ^ Sender state object - -> BtcAmount - -- ^ Amount to send (the actual payment amount is capped, so no invalid payment is created) - -> m (Either BtcError (ClientPayChanI BtcSig, SignedPayment)) - -- ^ Updated sender state & payment -createPayment cpc@MkClientPayChan{..} payVal = - createPaymentOfValue spcPrvKey (clearSig $ pcsPayment spcState) payVal >>= - either (return . Left) returnResult - where updateState pcs p = pcs { pcsPayment = p } - returnResult payment = return $ Right - (cpc { spcState = updateState spcState payment }, payment) - --- | Same as 'createPayment', but cap the supplied payment amount such that --- a valid payment is always created (perhaps of zero value). -cappedCreatePayment :: Monad m => - ClientPayChanI BtcSig - -> BtcAmount - -> m (ClientPayChanI BtcSig, SignedPayment, BtcAmount) - -- ^ (state, payment, actual payment amount) -cappedCreatePayment cpc amt = - createPayment cpc cappedAmount >>= - \resE -> case resE of - Right (newState,payment) -> return (newState, payment, cappedAmount) - Left e -> error $ "I fail at math" ++ show e - where - cappedAmount = min (availableChannelVal cpc) amt - --- |Produces a Bitcoin transaction which sends all channel funds back to the sender. --- Will not be accepted by the Bitcoin network until the expiration time specified in --- 'ChanParams'. Receiver should be aware of Bitcoin network time drift and the --- unpreditable nature of finding new blocks. -getRefundBitcoinTx - :: Monad m => - HC.PrvKeyC - -> ChanParams - -> FundingTxInfo - -> HC.Address -- ^ Refund address - -> SatoshisPerByte -- ^ Refund transaction fee - -- ^ Refund Bitcoin transaction. - -- Error only in case of insufficient value to cover fee - -- (dust outputs are accepted). - -> m (Either BtcError HT.Tx) -getRefundBitcoinTx prvKey cp fti refundAddr txFee = - fmap toHaskoinTx <$> - mkRefundTx prvKey cp fti refundAddr txFee - - --- |Create new 'ServerPayChan'. --- A channel is initialized with various information --- about the payment channel, as well as the first channel payment --- produced by the sender. -channelFromInitialPayment :: MonadTime m => - ChanParams -- ^ Specifies channel sender and receiver, plus channel expiration date - -> FundingTxInfo -- ^ Holds information about the Bitcoin transaction used to fund the channel - -> SignedPayment -- ^ Initial channel payment - -> m (Either PayChanError (BtcAmount, ServerPayChan)) -- ^Error or: value_received plus state object -channelFromInitialPayment cp fundInf payment = - let - metadata = Metadata () 0 [] (valueOf payment) ReadyForPayment - mkPayChanState sp = MkPayChanState sp (sigDataHash payment) - mkServChan sp = MkServerPayChan (mkPayChanState sp) metadata - zeroValPayment = mkUnsignedPayment cp fundInf (getP2SHFundingAddress cp) - zeroPaymFakeSig = spMapSigData (const $ getSigData payment) zeroValPayment - in - acceptPayment (mkServChan zeroPaymFakeSig) payment - - --- |Register, on the receiving side, a payment made by 'createPayment' 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. -acceptPayment :: MonadTime m => - ServerPayChanI a -- ^Receiver state object - -> SignedPayment -- ^Payment to verify and register - -> m (Either PayChanError (BtcAmount, ServerPayChanI a)) -- ^Value received plus new receiver state object -acceptPayment rpc@MkServerPayChan{..} payment = do - let newState = rpc { rpcState = updateWith payment } - updateWith p = rpcState { pcsPayment = p } - mkReturnVal v = Right (v, updateMetadata newState ) - valRecvdE <- paymentValueIncrease (pcsPayment rpcState) payment - return (S.checkChannelStatus rpc >> valRecvdE >>= mkReturnVal) - - --- |Same as 'acceptPayment' but accept only a payment of zero value --- with client-chosen change address. Used to produce the settlement --- transaction that returns unspent funds to the client. --- acceptClosingPayment :: --- ServerPayChanI a -- ^Receiver state object --- -> SignedPayment -- ^Payment to verify and register --- -> Either PayChanError (ServerPayChanI a) -- ^ Receiver state object --- acceptClosingPayment (MkServerPayChan state m) fp = --- acceptPayment futureTimeStamp newAddressState fp >>= --- \(amtRecv, newState) -> case amtRecv of --- 0 -> Right newState --- _ -> Left ClosingPaymentBadValue --- where newAddressState = MkServerPayChan --- { rpcState = S.setClientChangeAddress state (fpChangeAddr fp) --- , rpcMetadata = m --- } --- --- -- 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 --- 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 :: Monad m => - ServerPayChanI 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'). - -> HC.PrvKeyC -- ^ Function which produces a signature which verifies against 'cpReceiverPubKey' - -> SatoshisPerByte -- ^ Bitcoin transaction fee - -> DustPolicy - -> m (Either ReceiverError HT.Tx) -- ^ Settling Bitcoin transaction -getSettlementBitcoinTx rpc recvAdr prvKey txFee dp = - fmap toHaskoinTx <$> - getSignedSettlementTx rpc (const $ return prvKey) (mkChangeOut recvAdr txFee dp) - + hiding (ClosedServerChanX, ChangeOutFee, getClosedState) +import PaymentChannel.Client +import PaymentChannel.Server +import PaymentChannel.RBPCP.Parse +import PaymentChannel.Util +import PaymentChannel.Internal.Receiver.Util diff --git a/src/PaymentChannel/Client.hs b/src/PaymentChannel/Client.hs new file mode 100644 --- /dev/null +++ b/src/PaymentChannel/Client.hs @@ -0,0 +1,200 @@ +module PaymentChannel.Client +( validFundingInfo +, channelWithInitialPayment +, createPayment +, createPaymentCapped +, createClosingPayment +, getRefundBitcoinTx +, RefundTx +) +where + +import PaymentChannel.Server (getSettlementBitcoinTx) +import PaymentChannel.Internal.Payment +import PaymentChannel.Internal.Receiver.Util +import Bitcoin.Util (calcTxSize) +import PaymentChannel.Internal.Refund (RefundTx, mkRefundTx) +import PaymentChannel.Types +import Data.Functor.Identity (Identity(..)) +import Control.Exception (Exception, throw) +import qualified RBPCP.Types as RBPCP +import qualified Network.Haskoin.Crypto as HC +import qualified Network.Haskoin.Transaction as HT + + +data ChannelCreationError + = FundingError CreationError -- ^ Invalid funding output or dusty funding amount + | InsufficientFundingValue BtcAmount -- ^ Insufficient funding value to pay server-defined "open price" + | BadServerFundingAddress (ExpectFail HC.Address) + +instance Exception ChannelCreationError +instance Show ChannelCreationError where + show (FundingError e) = unwords + [ "Funding error:" + , show e + ] + show (InsufficientFundingValue val) = unwords + [ "Insufficient funding value to pay server-defined 'open price' of" + , show val + ] + show (BadServerFundingAddress expec) = unwords + [ "Disagreement on channel funding address.", show expec ] + +validFundingInfo + :: SendPubKey + -> LockTimeDate + -> RBPCP.FundingInfo + -> Either ChannelCreationError ChanParams +validFundingInfo sendPK lockTime RBPCP.FundingInfo{..} = + if correctAddress /= serversAddress + then Left $ BadServerFundingAddress $ serversAddress `FoundButExpected` correctAddress + else Right chanParams + where + serversAddress = fundingInfoFundingAddressCopy + getServerKey (RBPCP.Server pk) = pk + correctAddress = getP2SHFundingAddress chanParams + chanParams = ChanParams + sendPK + (MkRecvPubKey $ getServerKey fundingInfoServerPubkey) + lockTime + +channelWithInitialPayment + :: HC.PrvKeyC + -- ^ Client private key. Its corresponding public key was provided to server when fetching 'RBPCP.FundingInfo' + -> LockTimeDate + -- ^ Channel expiration date (was also provided to the server when fetching 'RBPCP.FundingInfo') + -> (HT.Tx, RBPCP.Vout) + -- ^ Funding transaction, plus transaction output index to use + -> RBPCP.FundingInfo + -- ^ Server-returned funding info + -> Either ChannelCreationError (ClientPayChanI BtcSig, SignedPayment) + -- ^ Client state and first payment (or error). +channelWithInitialPayment prvKey expTime fundingTxVout fi@RBPCP.FundingInfo{..} = + let serverConf = fromFundingInfo fi + mkPayChanState sp = MkPayChanState sp (fromInitialPayment sp) serverConf + mkClientChan sp = (MkClientPayChan (mkPayChanState sp) prvKey, sp) + openPrice = fromIntegral fundingInfoOpenPrice + clientPK = MkSendPubKey $ HC.derivePubKey prvKey + in do + cp <- validFundingInfo clientPK expTime fi + unsignedPay <- fmapL FundingError $ runConfM serverConf $ + mkUnsignedPayment cp fundingTxVout (getP2SHFundingAddress cp) + initialPay <- fmapL (const $ InsufficientFundingValue openPrice) $ + createPaymentInternal unsignedPay serverConf prvKey (openPrice :: BtcAmount) + Right $ mkClientChan initialPay + +-- |Create new payment of specified value, along with updated state containing this payment. +createPayment :: + ClientPayChan + -- ^ Sender state object + -> BtcAmount + -- ^ Amount to send + -> Either BtcError (ClientPayChan, SignedPayment) + -- ^ Updated sender state & payment +createPayment cpc@MkClientPayChan{..} val = do + payment <- createPaymentInternal (pcsPayment spcState) (pcsSettings spcState) spcPrvKey val + Right (updateClientState cpc payment, payment) + +updateClientState :: ClientPayChan -> SignedPayment -> ClientPayChan +updateClientState cpc@MkClientPayChan{..} payment = + cpc { spcState = updatePcs payment } + where + updatePcs p = spcState { pcsPayment = p } + + +-- |Create new payment of, at most, specified value, along with updated state containing this payment. +createPaymentCapped :: + ClientPayChan + -- ^ Sender state object + -> Capped BtcAmount + -- ^ Maximum amount to send + -> (ClientPayChan, SignedPayment, BtcAmount) + -- ^ Updated sender state, payment and actual payment value +createPaymentCapped = createPaymentCappedInternal + +-- | Same as 'createPaymentCapped', but accepts a client state without a signature +createPaymentCappedInternal :: + ClientPayChanI sd + -> Capped BtcAmount + -> (ClientPayChan, SignedPayment, BtcAmount) +createPaymentCappedInternal cpc@MkClientPayChan{..} cappedVal = + let + newPayment = failOnBug $ createPaymentInternal + (pcsPayment spcState) (pcsSettings spcState) spcPrvKey cappedVal + failOnBug (Right newPay) = newPay + failOnBug (Left e) = error $ "BUG: createPaymentCapped: capped amount math fail: " ++ show e + realVal = clientChangeVal (pcsPayment spcState) - clientChangeVal newPayment + updatePcs p = spcState { pcsPayment = p } + updateState p = cpc { spcState = updatePcs p } + in + (updateState newPayment, newPayment, realVal) + +-- |Create new payment of specified value, along with updated state containing this payment. +createPaymentInternal :: + PaymentValueSpec value + => Payment sd + -- ^ Sender state object + -> ServerSettings + -> HC.PrvKeyC + -- ^ Sender private key + -> value + -- ^ Amount to send. Either exact ('BtcAmount') or capped ('Capped BtcAmount') + -> Either BtcError SignedPayment + -- ^ Payment (+ payment value) +createPaymentInternal oldPayment servSettings prvKey payVal = + let + actualPayVal = paymentValue (clientChangeVal oldPayment) servSettings payVal + paymentE = runConfM servSettings $ createPaymentOfValue + prvKey (clearSig oldPayment) actualPayVal + -- BUG: Fail if we supplied the wrong private key to the signing function + -- (pubkey derived from private key does match client pubkey in 'ChanParams') + checkSignErr e = if isKeyError e then throw $ Bug e else e + in + fmapL checkSignErr paymentE + +-- TODO: cleanup +createClosingPayment + :: (ChangeOutFee fee, HasFee fee ) + => ClientPayChanI BtcSig -- ^ Client state + -> HC.Address -- ^ Client change address + -> fee -- ^ Settlement transaction fee (which equals value of closing payment) + -> (ClientPayChanI BtcSig, SignedPayment, BtcAmount) + -- ^ Closed state; closing payment; actual fee (capped to remaining channel value) +createClosingPayment clientState changeAddress fee = + createPaymentCapped newState (Capped $ absoluteFee 0 (dummySettleTxSize newState actualAmount) fee) + where + (newState, _, actualAmount) = createPaymentCappedInternal + newChangeAddrState (Capped $ absoluteFee 0 (dummySettleTxSize fakeSigNewAddrState (0 :: BtcAmount)) fee) + + dummySettleTxSize cpc' fee' = calcTxSize $ dummyClientSettleTx cpc' fee' + newChangeAddrState = _setClientChangeAddr clientState changeAddress + -- ### Dummy + fakeSigNewAddrState = mapSigData _invalidBtcSig newChangeAddrState + handleSettleRet (Right dummySettleTx) = dummySettleTx + handleSettleRet (Left e) = error $ "createClosingPayment. woops: " ++ show e + dummyAddress = HC.PubKeyAddress "0000000000000000000000000000000000000000" + dummyClientSettleTx :: ChangeOutFee txFee => ClientPayChan -> txFee -> HT.Tx + dummyClientSettleTx cpc txFee = toHaskoinTx . handleSettleRet . runDummy $ getSettlementBitcoinTx + (dummyFromClientState cpc) dummyAddress txFee DropDust + + +-- |Produces a Bitcoin transaction which sends all channel funds back to the sender. +-- Will not be accepted by the Bitcoin network until the expiration time specified in +-- 'ChanParams'. Receiver should be aware of Bitcoin network time drift and the +-- unpreditable nature of finding new blocks. +getRefundBitcoinTx + :: Monad m + => HC.PrvKeyC + -> ChanParams + -> FundingTxInfo + -> HC.Address -- ^ Refund address + -> SatoshisPerByte -- ^ Refund transaction fee + -- ^ Refund Bitcoin transaction. + -- Error only in case of insufficient value to cover fee + -- (dust outputs are accepted). + -> m (Either BtcError RefundTx) +getRefundBitcoinTx = + mkRefundTx + +{-# SPECIALIZE createPaymentInternal :: Payment BtcSig -> ServerSettings -> HC.PrvKeyC -> BtcAmount -> Either BtcError SignedPayment #-} +{-# SPECIALIZE createPaymentInternal :: Payment BtcSig -> ServerSettings -> HC.PrvKeyC -> Capped BtcAmount -> Either BtcError SignedPayment #-} 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 @@ -8,6 +8,7 @@ import PaymentChannel.Internal.Crypto.PubKey +import PaymentChannel.Internal.Util import Bitcoin.LockTime.Util import Bitcoin.Util import Network.Haskoin.Script @@ -18,13 +19,17 @@ -- |Defines channel: sender, receiver, and expiration date -data ChanParams = MkChanParams { - cpSenderPubKey :: SendPubKey, - cpReceiverPubKey :: RecvPubKey, +data ChanParams = ChanParams + { cpSenderPubKey :: SendPubKey + , cpReceiverPubKey :: RecvPubKey -- |Channel expiration date/time - cpLockTime :: LockTimeDate -} deriving (Eq, Show, Typeable, Generic, NFData) + , cpLockTime :: LockTimeDate + } deriving (Eq, Show, Typeable, Generic, NFData) +--data ClientParams = ClientParams +-- { +-- } + instance HasSendPubKey ChanParams where getSendPubKey = cpSenderPubKey @@ -39,18 +44,18 @@ deserHex >=> either fail return . fromRedeemScript instance Serialize ChanParams where - put (MkChanParams pks pkr lt) = + put (ChanParams pks pkr lt) = put pks >> put pkr >> put lt - get = MkChanParams <$> get <*> get <*> get + get = ChanParams <$> get <*> get <*> get instance HasLockTimeDate ChanParams where - getLockTimeDate MkChanParams{..} = cpLockTime + getLockTimeDate = cpLockTime -- |Generate 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 getRedeemScript :: ChanParams -> Script -getRedeemScript MkChanParams{..} = +getRedeemScript ChanParams{..} = let serverPubKey = getPubKey cpReceiverPubKey clientPubKey = getPubKey cpSenderPubKey @@ -71,7 +76,7 @@ lockTimeData, OP_NOP2, OP_DROP, -- OP_NOP2 is OP_CHECKLOCKTIMEVERIFY OP_ENDIF, OP_PUSHDATA clientPubKeyData OPCODE, OP_CHECKSIG]) - = MkChanParams + = ChanParams <$> deserEither clientPubKeyData <*> deserEither serverPubKeyData <*> decodeScriptLocktime lockTimeData @@ -101,8 +106,7 @@ decodeScriptLocktime :: forall lt. BtcLockTime lt => ScriptOp -> Either String lt decodeScriptLocktime op = maybe (Left "LockTime: Failed to decode script integer") - (maybe (Left "LockTIme: Failed to parse lockTime") Right . parseLockTime . fromIntegral) - . HI.cltvDecodeInt . B.unpack + (fmapL show . parseLockTime . fromIntegral) . HI.cltvDecodeInt . B.unpack =<< getPushBS op where -- TODO: Temporary. See https://github.com/haskoin/haskoin/issues/287 diff --git a/src/PaymentChannel/Internal/Config.hs b/src/PaymentChannel/Internal/Config.hs --- a/src/PaymentChannel/Internal/Config.hs +++ b/src/PaymentChannel/Internal/Config.hs @@ -1,25 +1,39 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module PaymentChannel.Internal.Config -( - module PaymentChannel.Internal.Config -, module Bitcoin.Config +( module PaymentChannel.Internal.Config +, module PaymentChannel.Internal.Types.Hour ) where -import Bitcoin.Config -import Data.Word -import qualified Data.Tagged as Tag +import Bitcoin.Types +import PaymentChannel.Internal.Util +import PaymentChannel.Internal.Types.Hour +import qualified RBPCP.Types as RBPCP -type Hour = Tag.Tagged "Hour" Word32 -toSeconds :: Num a => Hour -> a -toSeconds = fromIntegral . (* 3600) . Tag.unTagged - -configSettlePeriod :: Hour -configSettlePeriod = 10 - -getSettlePeriod = configSettlePeriod -getDustLimit = configDustLimit +class Monad m => HasConfSettlePeriod m where + -- | The server is allowed to close the payment channel + -- this many hours before the (in-blockchain) defined expiration date + confSettlePeriod :: m Hour +-- | Various server-defined settings +data ServerSettings = ServerSettings + { serverConfDustLimit :: BtcAmount + -- ^ The server will not accept a payment that leaves the client with less than this amount in change (unless it's exactly zero) + , serverConfSettlePeriod :: Hour + -- ^ The channel may be closed this number of hours *before* the in-blockchain expiration date + , serverConfMinDuration :: Hour + -- ^ Minimum duration of the payment channel + , serverConfOpenPrice :: BtcAmount + -- ^ Value of the initial payment needed to open the payment channel + } deriving (Eq, Show, Typeable, Generic, Serialize, ToJSON, FromJSON, NFData) +fromFundingInfo :: RBPCP.FundingInfo -> ServerSettings +fromFundingInfo RBPCP.FundingInfo{..} = + ServerSettings + (fromIntegral fundingInfoDustLimit) + (MkHour $ fromIntegral fundingInfoSettlementPeriodHours) + (MkHour $ fromIntegral fundingInfoMinDurationHours) + (fromIntegral fundingInfoOpenPrice) 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 @@ -5,8 +5,6 @@ , RecvPubKey(..) , HasSendPubKey(..) , HasRecvPubKey(..) -, KeyDeriveIndex -, HasKeyIndex(..) ) where import PaymentChannel.Internal.Util @@ -45,16 +43,4 @@ class HasRecvPubKey a where getRecvPubKey :: a -> RecvPubKey --- |Key index for a BIP32 root key -newtype KeyDeriveIndex = KeyDeriveIndex Word32 - deriving (Eq, Show, Serialize, Ord, Num, Enum, Real, Integral, FromJSON, ToJSON, NFData) - -class HasKeyIndex a where - getKeyIndex :: a -> KeyDeriveIndex - -instance HasKeyIndex HC.XPubKey where - getKeyIndex = KeyDeriveIndex . HC.xPubIndex - --- instance HasKeyIndex RecvPubKey where --- getKeyIndex = getKeyIndex . getReceiverPK diff --git a/src/PaymentChannel/Internal/Error.hs b/src/PaymentChannel/Internal/Error.hs --- a/src/PaymentChannel/Internal/Error.hs +++ b/src/PaymentChannel/Internal/Error.hs @@ -1,11 +1,7 @@ module PaymentChannel.Internal.Error -( - module PaymentChannel.Internal.Error.User -, module PaymentChannel.Internal.Error.Status -, module PaymentChannel.Internal.Error.Server -) +( module X ) where -import PaymentChannel.Internal.Error.User -import PaymentChannel.Internal.Error.Status -import PaymentChannel.Internal.Error.Server +import PaymentChannel.Internal.Error.User as X +import PaymentChannel.Internal.Error.Status as X +import PaymentChannel.Internal.Error.Internal as X diff --git a/src/PaymentChannel/Internal/Error/Internal.hs b/src/PaymentChannel/Internal/Error/Internal.hs new file mode 100644 --- /dev/null +++ b/src/PaymentChannel/Internal/Error/Internal.hs @@ -0,0 +1,21 @@ +module PaymentChannel.Internal.Error.Internal where + +import PaymentChannel.Internal.Error.User +import Bitcoin.Types +import Control.Exception + +data ReceiverError = + BadSignatureInState + | SettleSigningError BtcError + | BadClosedServerChan PayChanError + +instance Exception ReceiverError + +instance Show ReceiverError where + show BadSignatureInState = + "Signature verification failed for in-state (alread-verified) payment. Data corruption?" + show (BadClosedServerChan e) = + "Bad payment in ClosedServerChan produced by 'acceptClosingPayment': " ++ show e + show (SettleSigningError e) = + "Settlement signing error: " ++ show e + diff --git a/src/PaymentChannel/Internal/Error/Server.hs b/src/PaymentChannel/Internal/Error/Server.hs deleted file mode 100644 --- a/src/PaymentChannel/Internal/Error/Server.hs +++ /dev/null @@ -1,14 +0,0 @@ -module PaymentChannel.Internal.Error.Server where - -import Bitcoin.Types - -data ReceiverError = - SettleError BtcError - - -instance Show ReceiverError where - show (SettleError e) = - "Settlement error: " ++ show e - - - diff --git a/src/PaymentChannel/Internal/Error/Status.hs b/src/PaymentChannel/Internal/Error/Status.hs --- a/src/PaymentChannel/Internal/Error/Status.hs +++ b/src/PaymentChannel/Internal/Error/Status.hs @@ -1,17 +1,27 @@ +{-# LANGUAGE DeriveAnyClass #-} module PaymentChannel.Internal.Error.Status where +import PaymentChannel.Internal.Types import PaymentChannel.Internal.Metadata.Types +import Control.Exception class HasHttpError a where getHttpError :: a -> HTTPError -type HTTPError = (Int,String) +data HTTPError = HTTPError { heCode :: Int, heStatus :: String } + deriving (Eq, Generic, NFData, ToJSON, FromJSON, Serialize) --- instance HasHttpError PayChanStatus where --- +instance Show HTTPError where + show (HTTPError c e) = unwords + [""] +instance Exception HTTPError + +instance HasHttpError HTTPError where + getHttpError = id + checkReadyForPayment :: PayChanStatus -> Maybe HTTPError checkReadyForPayment ReadyForPayment = Nothing -checkReadyForPayment PaymentInProgress = Just (400, "Channel busy (payment in progress)") -checkReadyForPayment SettlementInProgress = Just (409, "Settlement in progress") -checkReadyForPayment ChanClosed = Just (410, "Channel closed") +checkReadyForPayment PaymentInProgress = Just $ HTTPError 400 "Channel busy (payment in progress)" +checkReadyForPayment SettlementInProgress = Just $ HTTPError 409 "Settlement in progress" +checkReadyForPayment (ChannelClosed _) = Just $ HTTPError 410 "Channel closed" 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 @@ -2,33 +2,62 @@ module PaymentChannel.Internal.Error.User where +import PaymentChannel.RBPCP.Parse import PaymentChannel.Internal.Error.Status (HTTPError) +import PaymentChannel.Internal.Receiver.Open (OpenError) import Bitcoin.Compare +import Bitcoin.LockTime.Types (LockTimeParseError) import PaymentChannel.Internal.Types import PaymentChannel.Internal.Util -import GHC.Generics +import GHC.Generics +import Control.Exception +import qualified Network.Haskoin.Script as HS + data PayChanError = - SigVerifyFailed -- ^ Signature verification failed - | BadSigHashFlag -- ^ Unexpected 'SigHash' flag. Expected: SIGHASH_SINGLE|ANYONECANPAY. - | BadPaymentValue BtcAmount -- ^ Payment assigns less value to server than previous payment. Client change value is greater by the specified 'BtcAmount'. + SigVerifyFailed -- ^ Signature verification failed + | LockTimeParseError LockTimeParseError + | BadSigHashFlag HS.SigHash HS.SigHash -- ^ Unexpected 'SigHash' flag. Expected: SIGHASH_SINGLE|ANYONECANPAY. + | BadPaymentValue BtcAmount -- ^ Payment assigns less value to server than previous payment. Client change value is greater by the specified 'BtcAmount'. | PaymentError (TxMismatch ChanParams) - | 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, NFData) + | ChannelExpired -- ^ Channel has expired or is too close to expiration date + | StatusError HTTPError -- ^ Channel not ready for payment. 409=try again; 410=channel gone. + | RBPCPError ParseError -- ^ Failed to parse RBPCP payment + | OpenError OpenError -- ^ Channel-open error + deriving (Eq, Generic, NFData, ToJSON, FromJSON, Serialize) + +class IsPayChanError e where + mkChanErr :: e -> PayChanError + +instance IsPayChanError LockTimeParseError where + mkChanErr = LockTimeParseError + +instance IsPayChanError HTTPError where + mkChanErr = StatusError + +instance IsPayChanError ParseError where + mkChanErr = RBPCPError + +instance IsPayChanError OpenError where + mkChanErr = OpenError + + +instance Exception PayChanError + + instance Show PayChanError where - show SigVerifyFailed = "Signature verification failed" - show BadSigHashFlag = "Unexpected SIGHASH flag. Expected: SIGHASH_SINGLE|ANYONECANPAY (0x83)" + show SigVerifyFailed = "signature verification failed" + show (LockTimeParseError e) = show e + show (BadSigHashFlag sh1 sh2) = + "unexpected SIGHASH flag: " ++ show sh1 ++ + ". expected: " ++ show sh2 show (BadPaymentValue valDiff) = "out-of-order payment (assigns " ++ show valDiff ++ " less value to receiver)" - show ClosingPaymentBadValue = "payment not of zero value." ++ - " cannot receive value in closing payment." show ChannelExpired = "channel too close to expiration date" - show (StatusError (_,e)) = - "Status error:" ++ e + show (StatusError he) = unwords + ["status error:", show he] show (PaymentError (TxInMismatch (InPrevOutMismatch op _))) = "unexpected outpoint. expected: " ++ show op show (PaymentError (TxOutMisMatch (OutAddressMismatch addr _))) = @@ -36,6 +65,7 @@ show (PaymentError (TxInMismatch (InRdmScrMismatch scr _))) = "unexpected redeemScript. expected: " ++ cs (serHex scr) show (PaymentError e) = "unexpected error: " ++ show e - + show (RBPCPError pe) = "failed to parse payment: " ++ show pe + show (OpenError oe) = "open error: " ++ show oe -- instance Serialize PayChanError -- Generic PayChanError instance 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 @@ -20,14 +20,17 @@ , mdChannelStatus :: PayChanStatus } deriving (Eq, Typeable, Show, Generic, NFData) +initialMetadata :: MetadataI () +initialMetadata = Metadata () 0 [] 0 ReadyForPayment + type MetadataIdx = MetadataI KeyDeriveIndex data PayChanStatus = ReadyForPayment | PaymentInProgress | SettlementInProgress - | ChanClosed - deriving (Eq, Typeable, Show, Read, Generic, Serialize, NFData) + | ChannelClosed SignedPayment -- ^ The closing channel payment + deriving (Eq, Typeable, Show, Generic, ToJSON, FromJSON, Serialize, NFData) instance Serialize a => Serialize (MetadataI a) where put Metadata{..} = @@ -38,15 +41,13 @@ >> put mdChannelStatus get = Metadata <$> get <*> get <*> get <*> get <*> get - -- Generic instance ToJSON a => ToJSON (MetadataI a) instance FromJSON a => FromJSON (MetadataI a) -instance ToJSON PayChanStatus where - toJSON = String . cs . show - -instance FromJSON PayChanStatus where - parseJSON = withText "PayChanStatus" (return . read . cs) +-- instance ToJSON PayChanStatus where +-- toJSON = String . cs . show +--instance FromJSON PayChanStatus where +-- parseJSON = withText "PayChanStatus" $ \txt -> -- (return . read . cs) diff --git a/src/PaymentChannel/Internal/Payment/Create.hs b/src/PaymentChannel/Internal/Payment/Create.hs --- a/src/PaymentChannel/Internal/Payment/Create.hs +++ b/src/PaymentChannel/Internal/Payment/Create.hs @@ -1,56 +1,76 @@ module PaymentChannel.Internal.Payment.Create -( - mkUnsignedPayment +( mkUnsignedPayment , createPaymentOfValue +, CreationError , module Export ) where -import PaymentChannel.Internal.Payment.Types as Export +import PaymentChannel.Internal.Payment.Types as Export --- import RBPCP.Types -import PaymentChannel.Internal.RBPCP.Parse -import PaymentChannel.Internal.Types -import PaymentChannel.Internal.ChanScript -import Bitcoin.Util -import Bitcoin.SinglePair -import Bitcoin.Compare -import PaymentChannel.Internal.Util -import qualified Network.Haskoin.Transaction as HT -import qualified Network.Haskoin.Crypto as HC -import qualified Network.Haskoin.Script as HS -import qualified Data.List.NonEmpty as NE +import qualified Network.Haskoin.Transaction as HT +import qualified Network.Haskoin.Crypto as HC +import Bitcoin.SpendCond.Util (singlePrevIn, PickOutError) +-- import Bitcoin.Dust (getDustLimit) +import Control.Monad.Trans.Either +import Control.Monad.Trans.Class (lift) +data CreationError + = BadFundingOutput (PickOutError ChanParams) + | DustyFundingAmount BtcAmount + deriving Show -- TODO -mkUnsignedPayment :: ChanParams -> FundingTxInfo -> HC.Address -> Payment () -mkUnsignedPayment cp CFundingTxInfo{..} refundAddr = - mkSigSinglePair fundingIn changeOut - where - changeOut = mkBtcOut refundAddr ftiOutValue - fundingIn = mkNoSigTxIn (HT.OutPoint ftiHash ftiOutIndex) - (nonDusty ftiOutValue) - (Pay2 $ ScriptHash $ Cond cp) +mkUnsignedPayment :: + HasConfDustLimit m + => ChanParams + -> (HT.Tx, Word32) + -> HC.Address + -> m (Either CreationError UnsignedPayment) +mkUnsignedPayment cp (tx,idx) refundAddr = runEitherT $ do + input <- hoistEither $ fmapL BadFundingOutput $ singlePrevIn tx cp idx + dustLimit <- lift confDustLimit + fundingVal <- hoistEither . fmapL (const $ DustyFundingAmount dustLimit) + =<< lift (mkNonDusty $ btcInValue input) + return $ mkSigSinglePair input (mkBtcOut refundAddr fundingVal) -createPaymentOfValue :: ( Monad m, Show t - , TransformSigData BtcSig () r - , SignatureScript t BtcSig - , SpendFulfillment BtcSig r - , HasSpendCond r t - ) => + +createPaymentOfValue :: + ( HasConfDustLimit m + , TransformSigData BtcSig () r +-- , SignatureScript t r BtcSig + , SpendFulfillment BtcSig r +-- , HasSpendCond r t + , Show r + ) => HC.PrvKeyC - -> SigSinglePair t () + -> SigSinglePair t r () -> BtcAmount - -> m (Either BtcError (SigSinglePair t BtcSig)) -createPaymentOfValue prvKey ssp payVal = - either (return . Left) (signPair prvKey) (decrementClientValue ssp payVal) + -> m (Either BtcError (SigSinglePair t r BtcSig)) +createPaymentOfValue prvKey ssp payVal = do + newSspE <- decrementClientValue ssp payVal + either (return . Left) (signPair prvKey) newSspE -decrementClientValue :: SigSinglePair r () -> BtcAmount -> Either BtcError (SigSinglePair r ()) +decrementClientValue :: + HasConfDustLimit m + => SigSinglePair t r () + -> BtcAmount + -> m (Either BtcError (SigSinglePair t r ())) decrementClientValue sp@SigSinglePair{..} decVal = do - newVal <- mkNonDusty (currentVal - decVal) - Right $ sp { singleOutput = replaceValue singleOutput newVal } + newValE <- mkNonDusty (currentVal - decVal) + return (newValE >>= \newVal -> Right $ sp { singleOutput = replaceValue singleOutput newVal }) where currentVal = nonDusty $ btcAmount singleOutput replaceValue out val = out { btcAmount = val } + + + + + + + + + + diff --git a/src/PaymentChannel/Internal/Payment/Types.hs b/src/PaymentChannel/Internal/Payment/Types.hs --- a/src/PaymentChannel/Internal/Payment/Types.hs +++ b/src/PaymentChannel/Internal/Payment/Types.hs @@ -8,6 +8,7 @@ import PaymentChannel.Internal.Types import Bitcoin.Types +import Bitcoin.Util import Bitcoin.SinglePair import Bitcoin.SpendCond.Cond import Bitcoin.Signature @@ -23,17 +24,23 @@ data PaymentScriptSig = PaymentScriptSig { sssClientSig :: BtcSig , sssServerSig :: BtcSig - } + } deriving (Eq, Show) +type SettleTx = BtcTx P2SH ChanParams PaymentScriptSig + +instance HasSigner BtcSig ChanParams where + signerPubKey = Tagged . getPubKey . cpSenderPubKey instance TransformSigData BtcSig () ChanParams where - mkSigData _ btcSig _ = btcSig + mkSigData _ = Tagged +instance HasSigner PaymentScriptSig ChanParams where + signerPubKey = Tagged . getPubKey . cpReceiverPubKey instance TransformSigData PaymentScriptSig BtcSig ChanParams where - mkSigData clientSig serverSig _ = PaymentScriptSig clientSig serverSig + mkSigData oldSd = Tagged . PaymentScriptSig oldSd -- Two signatures instance SpendFulfillment PaymentScriptSig ChanParams where - rawSigs PaymentScriptSig{..} MkChanParams{..} = + rawSigs PaymentScriptSig{..} ChanParams{..} = [ (getPubKey cpReceiverPubKey, sssClientSig) , (getPubKey cpSenderPubKey , sssServerSig) ] signatureScript PaymentScriptSig{..} _ = Script @@ -43,7 +50,7 @@ -- Single (client) signature instance SpendFulfillment BtcSig ChanParams where - rawSigs clientSig MkChanParams{..} = + rawSigs clientSig ChanParams{..} = [ (getPubKey cpSenderPubKey, clientSig) ] signatureScript _ _ = Script [] --TODO: separate rawSigs from signatureScript? diff --git a/src/PaymentChannel/Internal/Payment/Verify.hs b/src/PaymentChannel/Internal/Payment/Verify.hs --- a/src/PaymentChannel/Internal/Payment/Verify.hs +++ b/src/PaymentChannel/Internal/Payment/Verify.hs @@ -1,44 +1,63 @@ module PaymentChannel.Internal.Payment.Verify -( - paymentValueIncrease +( paymentValueIncrease +, StateSignature +, _invalidBtcSig ) where - import PaymentChannel.Internal.Payment.Types as Export import PaymentChannel.Internal.Error.User - --- import RBPCP.Types -import PaymentChannel.Internal.RBPCP.Parse -import PaymentChannel.Internal.Types -import PaymentChannel.Internal.ChanScript -import Bitcoin.Util -import Bitcoin.SinglePair +import PaymentChannel.Internal.Error.Internal (ReceiverError(BadSignatureInState)) import Bitcoin.Compare -import PaymentChannel.Internal.Util -import qualified Network.Haskoin.Transaction as HT -import qualified Network.Haskoin.Crypto as HC -import qualified Network.Haskoin.Script as HS -import qualified Data.List.NonEmpty as NE +import Control.Exception (throw) +import Debug.Trace -paymentValueIncrease :: MonadTime m => - Payment BtcSig - -> Payment BtcSig +-- | When we don't have a valid signature for the 'Payment' in the state +-- its signature data will be an 'InvalidSig'. Conversion +-- to a BtcSig is for backwards compatibility with 'payValIncrease' etc. +class StateSignature a where + checkStateSig :: Payment a -> Either VerifyError () + _btcSigPossiblyFake :: Payment a -> Payment BtcSig -- ^ For backwards compatibilty with 'payValIncrease' (which doesn't look at signature data) + +instance StateSignature BtcSig where + checkStateSig = singlePairVerifySig + _btcSigPossiblyFake = id + +instance StateSignature InvalidSig where + checkStateSig = const $ Right () + _btcSigPossiblyFake = mapSigData _invalidBtcSig + +-- | WARNING: Produces invalid 'BtcSig' +_invalidBtcSig :: InvalidSig -> BtcSig +_invalidBtcSig (MkInvalidSig sh) = BtcSig dummySig sh + +-- | Throws 'BadSignatureInState' on invalid in-state payment signature +paymentValueIncrease :: + ( MonadTime m + , StateSignature stateSigData + ) => + PayChanState stateSigData -- ^ State with old payment + -> Payment BtcSig -- ^ New payment -> m (Either PayChanError BtcAmount) -paymentValueIncrease sp1 sp2 = do - fundingLocked <- fundingIsLocked sp2 - if fundingLocked then return checkedPayVal else return $ Left ChannelExpired +paymentValueIncrease state newPayment = do + let settlePeriod = runConfM (pcsSettings state) confSettlePeriod + fundingLocked <- fundingIsLocked (toSeconds settlePeriod) newPayment + return $ + if fundingLocked + then checkedPayVal (pcsPayment state) newPayment + else Left ChannelExpired where - checkedPayVal = do - valRecvd <- payValIncrease sp1 sp2 - _ <- fmapL (const SigVerifyFailed) (singlePairVerifySig sp2) + checkedPayVal statePayment payment = do + valRecvd <- payValIncrease (_btcSigPossiblyFake statePayment) payment + fmapL (const $ throw BadSignatureInState) (checkStateSig statePayment) + _ <- fmapL (const SigVerifyFailed) (singlePairVerifySig payment) return valRecvd payValIncrease :: - Payment BtcSig - -> Payment BtcSig + Payment BtcSig -- ^ Old, in-state payment + -> Payment BtcSig -- ^ New payment -> Either PayChanError BtcAmount payValIncrease sp1 sp2 = comparePayments sp1 sp2 >>= @@ -60,5 +79,6 @@ (tx1,tx2) = (toBtcTx sp1, toBtcTx sp2) eqIgnoreVal di = if not $ eqIgnoreOutVal (IgnoreSigData tx1) (IgnoreSigData tx2) - then Left BadSigHashFlag -- Means sig hash flags differ + -- Means sig hash flags differ + then Left $ show (tx1,tx2) `trace` BadSigHashFlag (bsSigFlag $ getSigData sp2) (bsSigFlag $ getSigData sp1) else Right di diff --git a/src/PaymentChannel/Internal/RBPCP/Parse.hs b/src/PaymentChannel/Internal/RBPCP/Parse.hs deleted file mode 100644 --- a/src/PaymentChannel/Internal/RBPCP/Parse.hs +++ /dev/null @@ -1,57 +0,0 @@ -module PaymentChannel.Internal.RBPCP.Parse -( - fromPaymentData -, toPaymentData -) -where - -import RBPCP.Types -import PaymentChannel.Internal.Util -import PaymentChannel.Internal.Types -import Bitcoin.SpendCond.Cond --- import PaymentChannel.Internal.Payment.Types () -import qualified Network.Haskoin.Transaction as HT -import qualified Data.List.NonEmpty as NE - - -data ParseError = - BadRedeemScript String - | BtcError BtcError - -fromPaymentData :: BtcAmount -> PaymentData -> Either ParseError (SigSinglePair ChanParams BtcSig) -fromPaymentData fundVal pd = do - input <- paymentDataIn fundVal pd - output <- paymentDataOut pd - Right $ SigSinglePair input output - -paymentDataIn :: BtcAmount -> PaymentData -> Either ParseError (InputG ChanParams BtcSig) -paymentDataIn fundVal PaymentData{..} = - chanParamsE >>= Right . mapSigData (const paySig) . mkInput - where - mkInput = mkNoSigTxIn prevOut fundVal - prevOut = HT.OutPoint paymentDataFundingTxid paymentDataFundingVout - chanParamsE = fmapL BadRedeemScript $ fromRedeemScript (fromHex paymentDataRedeemScript) - -- TODO: strict DER/signature parsing - paySig = MkBtcSig (fromHex paymentDataSignatureData) - (fromHex paymentDataSighashFlag) - -paymentDataOut :: PaymentData -> Either ParseError BtcOut -paymentDataOut PaymentData{..} = - mkBtcOut paymentDataChangeAddress <$> - fmapL BtcError (mkNonDusty outAmount) - where - outAmount = fromIntegral paymentDataChangeValue :: BtcAmount - -toPaymentData :: SigSinglePair (P2SH ChanParams) BtcSig -> PaymentData -toPaymentData (SigSinglePair input output) = - PaymentData - { paymentDataRedeemScript = JsonHex . getRedeemScript . getCond . btcInType $ input - , paymentDataFundingTxid = HT.outPointHash . btcPrevOut $ input - , paymentDataFundingVout = HT.outPointIndex . btcPrevOut $ input - , paymentDataSignatureData = JsonHex . bsSig . btcSigData $ input - , paymentDataSighashFlag = JsonHex . bsSigFlag . btcSigData $ input - , paymentDataChangeValue = fromIntegral . nonDusty . btcAmount $ output - , paymentDataChangeAddress = btcAddress output - } - - diff --git a/src/PaymentChannel/Internal/Receiver/Open.hs b/src/PaymentChannel/Internal/Receiver/Open.hs new file mode 100644 --- /dev/null +++ b/src/PaymentChannel/Internal/Receiver/Open.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DeriveAnyClass #-} +module PaymentChannel.Internal.Receiver.Open +( OpenError(..) +, initialServerState +) +where + +import PaymentChannel.Internal.Util +import PaymentChannel.Internal.Receiver.Types +import PaymentChannel.RBPCP.Parse (ParseError, fromPaymentData, parseRedeemScript) +import Bitcoin.SpendCond.Util (singlePrevIn, PickOutError) +import qualified RBPCP.Types as RBPCP +import qualified Network.Haskoin.Transaction as HT + + +data OpenError + = PickOutError (PickOutError ChanParams) -- ^ Incorrect output specified + | ResourcePaymentMismatch HT.Tx HT.TxHash -- Redirect + | FundingTxError ParseError + | FundingTxDustOut BtcAmount + | IncorrectInitialPaymentValue (ExpectFail BtcAmount) + | InsufficientDuration Hour + deriving (Eq, Generic, NFData, ToJSON, FromJSON, Serialize) + +-- | Derive the initial (zero-value) server state from +-- the funding transaction and "initial payment"-'PaymentData' +initialServerState :: + ServerSettings + -> HT.Tx + -> RBPCP.PaymentData + -> Either OpenError (ServerPayChanG () InvalidSig) +initialServerState cfg@ServerSettings{..} tx pd@RBPCP.PaymentData{..} + | RBPCP.btcTxId paymentDataFundingTxid /= HT.txHash tx = + Left $ ResourcePaymentMismatch tx (RBPCP.btcTxId paymentDataFundingTxid) + | otherwise = do + let rdmScrE = fmapL FundingTxError $ parseRedeemScript pd + mkInput scr = fmapL PickOutError (singlePrevIn tx scr paymentDataFundingVout) + sp <- mkSignedPayment =<< mkInput =<< rdmScrE + brandNewState cfg sp + where + mkSignedPayment input = fmapL FundingTxError $ runConfM cfg $ + fromPaymentData (btcInValue input) pd + +brandNewState :: + ServerSettings + -> SignedPayment + -> Either OpenError (ServerPayChanG () InvalidSig) +brandNewState cfg@ServerSettings{..} signedPaym = do + let setErr = fmapL (const $ FundingTxDustOut serverConfDustLimit) + newSp <- setErr $ runConfM cfg $ resetClientChangeVal signedPaym + Right $ MkServerPayChan (mkChanState newSp) initialMetadata + where + mkChanState sp = MkPayChanState sp (fromInitialPayment signedPaym) cfg + +instance Show OpenError where + show (PickOutError e) = "Incorrect funding output specified: " ++ show e + show (ResourcePaymentMismatch tx h) = unwords + [ "prevOutHash mismatch for payment data/payment resource. resource: " + , show (cs . encode . HT.txHash $ tx :: String) + , "data:" + , show (cs . encode $ h :: String) + ] + show (FundingTxError pe) = "funding tx error: " ++ show pe + show (FundingTxDustOut dl) = unwords + ["funding output below dust limit of", show dl] + show (IncorrectInitialPaymentValue expec) = unwords + ["incorrect initial payment-value.", show expec] + show (InsufficientDuration minDur) = unwords + ["insufficient channel duration. expected at least:", show minDur] + diff --git a/src/PaymentChannel/Internal/Receiver/Settle.hs b/src/PaymentChannel/Internal/Receiver/Settle.hs --- a/src/PaymentChannel/Internal/Receiver/Settle.hs +++ b/src/PaymentChannel/Internal/Receiver/Settle.hs @@ -11,7 +11,8 @@ import qualified Network.Haskoin.Transaction as HT -newMetaAfterSettle :: ServerPayChanI a -> MetadataI a +{- +newMetaAfterSettle :: ServerPayChanI kd -> MetadataI a newMetaAfterSettle rpc@MkServerPayChan{rpcMetadata = prevMd} = prevMd { mdSettledValue = Settle.infoFromState rpc : mdSettledValue prevMd :: [Settle.SettleInfo] @@ -21,16 +22,18 @@ -- |What would the status of the payment channel be -- if the settlement transaction were published right now? -statusAfterSettlement :: ServerPayChanI a -> PayChanStatus +statusAfterSettlement :: ServerPayChanI kd -> PayChanStatus statusAfterSettlement rpc@MkServerPayChan{rpcState = pcs} = if changeAddress pcs /= fundingAddress rpc then -- channelIsExhausted - ChanClosed + ChannelClosed else ReadyForPayment where changeAddress = clientChangeAddr . pcsPayment --- settleChanState :: SignedBtcTx ChanParams -> ServerPayChanI a -> ServerPayChanI a +-} + +-- settleChanState :: SignedBtcTx ChanParams -> ServerPayChanI kd -> ServerPayChanI kd -- settleChanState tx rpc@MkServerPayChan{rpcState = pcs} = -- undefined -- where 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 @@ -3,35 +3,69 @@ module PaymentChannel.Internal.Receiver.Types ( module PaymentChannel.Internal.Receiver.Types -, module PaymentChannel.Internal.Types -, module PaymentChannel.Internal.State +, module X +, SettleTx ) where -import PaymentChannel.Internal.State -import PaymentChannel.Internal.Types -import PaymentChannel.Internal.Metadata.Types -import PaymentChannel.Internal.Util +import PaymentChannel.Internal.Payment.Types (SettleTx) +import PaymentChannel.Internal.Types as X +import PaymentChannel.Internal.Metadata.Types as X +import PaymentChannel.Internal.Types.MonadConf as X -- |ServerPayChan without receiver key metadata type ServerPayChan = ServerPayChanI () -- |ServerPayChan with BIP32, "extended key" index as metadata -type ServerPayChanX = ServerPayChanI KeyDeriveIndex +type ServerPayChanX = ServerPayChanI ExtPub -- |State object for the value receiver. "kd" is used to store --- information about the receiver key(s) used for this state object. -data ServerPayChanI kd = MkServerPayChan { +-- information about the receiver key(s) used for this state object. +data ServerPayChanG kd sd = MkServerPayChan { -- |Internal state object - rpcState :: PayChanState BtcSig + rpcState :: PayChanState sd , rpcMetadata :: MetadataI kd } deriving (Eq, Show, Typeable, Generic, Serialize, NFData) -instance HasSendPubKey (ServerPayChanI a) where getSendPubKey = getSendPubKey . rpcState -instance HasRecvPubKey (ServerPayChanI a) where getRecvPubKey = getRecvPubKey . rpcState +instance HasLockTimeDate (ServerPayChanG kd sd) where + getLockTimeDate = getLockTimeDate . rpcState +type ServerPayChanI kd = ServerPayChanG kd BtcSig +dummyFromClientState :: ClientPayChan -> ServerPayChanI () +dummyFromClientState MkClientPayChan{..} = + MkServerPayChan spcState initialMetadata + +data ClosedServerChanI kd = MkClosedServerChan + { cscState :: ServerPayChanG kd BtcSig + , cscClosingPayment :: SignedPayment + } deriving (Eq, Show, Typeable, Generic, Serialize, NFData) + +type ClosedServerChan = ClosedServerChanI () +type ClosedServerChanX = ClosedServerChanI ExtPub + +getClosedState :: ClosedServerChanI kd -> ServerPayChanI kd +getClosedState = cscState + +getClosedPayment :: ClosedServerChanI kd -> SignedPayment +getClosedPayment = cscClosingPayment + +instance HasSendPubKey (ServerPayChanG kd sd) where getSendPubKey = getSendPubKey . rpcState +instance HasRecvPubKey (ServerPayChanG kd sd) where getRecvPubKey = getRecvPubKey . rpcState + +instance HasSigData (ServerPayChanG kd) where + mapSigData f spc@MkServerPayChan{..} = + spc { rpcState = + mapSigData f rpcState + } + +instance SetClientChangeAddr (ServerPayChanG kd) where + _setClientChangeAddr spc@MkServerPayChan{..} addr = + spc { rpcState = + _setClientChangeAddr rpcState addr + } + instance ToJSON d => ToJSON (ServerPayChanI d) where toJSON rpc = object [ "state" .= rpcState rpc @@ -43,5 +77,4 @@ MkServerPayChan <$> o .: "state" <*> o .: "metadata" - diff --git a/src/PaymentChannel/Internal/Receiver/Util.hs b/src/PaymentChannel/Internal/Receiver/Util.hs --- a/src/PaymentChannel/Internal/Receiver/Util.hs +++ b/src/PaymentChannel/Internal/Receiver/Util.hs @@ -1,6 +1,17 @@ module PaymentChannel.Internal.Receiver.Util -( - module PaymentChannel.Internal.Receiver.Util +( updState +, mkExtendedKeyRPC +--, mkDummyExtendedRPC +, metaKeyIndex +, setMetadata +, setChannelStatus +, getChannelStatus +, markAsBusy +, isReadyForPayment +, checkChannelStatus +, getClosingPayment +, calcNewData +, updateMetadata , module PaymentChannel.Internal.Receiver.Types , module PaymentChannel.Internal.Class.Value ) @@ -17,55 +28,71 @@ --- KeyDeriveIndex +updState :: ServerPayChanG kd sd -> SignedPayment -> ServerPayChanG kd BtcSig +updState rpc p = + rpc { rpcState = replacePayment (rpcState rpc) p } + where + replacePayment state p' = state { pcsPayment = p' } --- |Create a 'ServerPayChanX', which has an associated BIP32 key index, from a +-- |Create a 'ServerPayChanX', which has an associated BIP32 extended pubkey, from a -- 'ServerPayChan' -mkExtendedKeyRPC :: ServerPayChanI a -> HC.XPubKey -> Maybe ServerPayChanX +mkExtendedKeyRPC :: ServerPayChanI kd -> ExtPub -> Maybe ServerPayChanX mkExtendedKeyRPC rpc@(MkServerPayChan pcs _) xpk = -- Check that it's the right pubkey first - if xPubKey xpk == getPubKey (getRecvPubKey pcs) then - Just $ mkExtendedKeyRPCUnsafe (fromIntegral $ HC.xPubIndex xpk) rpc + if getKey xpk == getPubKey (getRecvPubKey pcs) then + Just $ mkExtendedKeyRPCUnsafe xpk rpc else Nothing -mkExtendedKeyRPCUnsafe :: Word32 -> ServerPayChanI a -> ServerPayChanX -mkExtendedKeyRPCUnsafe i rpc = +mkExtendedKeyRPCUnsafe :: ExtPub -> ServerPayChanI kd -> ServerPayChanX +mkExtendedKeyRPCUnsafe xPub rpc = rpc { rpcMetadata = - Metadata (fromIntegral i) 0 [] (valueOf $ rpcState rpc) ReadyForPayment + Metadata xPub 0 [] (valueOf $ rpcState rpc) ReadyForPayment } -mkDummyExtendedRPC :: ServerPayChanI a -> ServerPayChanX -mkDummyExtendedRPC = mkExtendedKeyRPCUnsafe 0 +--mkDummyExtendedRPC :: ServerPayChanI kd -> ServerPayChanX +--mkDummyExtendedRPC = mkExtendedKeyRPCUnsafe 0 metaKeyIndex :: ServerPayChanI KeyDeriveIndex -> KeyDeriveIndex metaKeyIndex = mdKeyData . rpcMetadata +-- | Server/receiver: set pubkey metadata +setMetadata :: ServerPayChanG a sd -> b -> ServerPayChanG b sd +setMetadata sp@MkServerPayChan{..} kd = + sp { rpcMetadata = + rpcMetadata { mdKeyData = kd } + } + -- Status -setChannelStatus :: PayChanStatus -> ServerPayChanI a -> ServerPayChanI a +setChannelStatus :: PayChanStatus -> ServerPayChanG kd sd -> ServerPayChanG kd sd setChannelStatus s pcs@MkServerPayChan{ rpcMetadata = meta } = pcs { rpcMetadata = metaSetStatus s meta } -getChannelStatus :: ServerPayChanI a -> PayChanStatus +getChannelStatus :: ServerPayChanG kd sd -> PayChanStatus getChannelStatus MkServerPayChan{ rpcMetadata = meta } = metaGetStatus meta -markAsBusy :: ServerPayChanI a -> ServerPayChanI a +markAsBusy :: ServerPayChanG kd sd -> ServerPayChanG kd sd markAsBusy = setChannelStatus PaymentInProgress -isReadyForPayment :: ServerPayChanI a -> Bool +isReadyForPayment :: ServerPayChanG kd sd -> Bool isReadyForPayment = (== ReadyForPayment) . getChannelStatus -checkChannelStatus :: ServerPayChanI a -> Either PayChanError (ServerPayChanI a) +checkChannelStatus :: ServerPayChanG kd sd -> Either PayChanError (ServerPayChanG kd sd) checkChannelStatus rpc = maybe (Right rpc) (Left . StatusError) (checkReadyForPayment $ getChannelStatus rpc) +getClosingPayment :: ServerPayChanI kd -> Maybe SignedPayment +getClosingPayment spc = + case getChannelStatus spc of + ChannelClosed p -> Just p + _ -> Nothing -- Metadata calcNewData :: MetadataI a -> PayChanState BtcSig -> MetadataI a @@ -74,6 +101,8 @@ where checkedVal = if newValRecvd < oldValRecvd then error "BUG: Value lost :(" else newValRecvd newValRecvd = valueOf pcs -updateMetadata :: ServerPayChanI a -> ServerPayChanI a +updateMetadata :: ServerPayChanI kd -> ServerPayChanI kd updateMetadata rpc@MkServerPayChan{..} = rpc { rpcMetadata = calcNewData rpcMetadata rpcState } + + diff --git a/src/PaymentChannel/Internal/Refund.hs b/src/PaymentChannel/Internal/Refund.hs --- a/src/PaymentChannel/Internal/Refund.hs +++ b/src/PaymentChannel/Internal/Refund.hs @@ -10,11 +10,9 @@ -type RefundTx = BtcTx (P2SH ChanParams) RefundScriptSig -type UnsignedRefundTx = UnsignedBtcTx (P2SH ChanParams) +type RefundTx = BtcTx P2SH ChanParams RefundScriptSig +type UnsignedRefundTx = UnsignedBtcTx P2SH ChanParams -instance TransformSigData RefundScriptSig () ChanParams where - mkSigData _ sig _ = RefundScriptSig sig -- | Returns Nothing if there's not enough value available to cover paying the specified fee -- without producing a dust output. @@ -24,7 +22,7 @@ baseIn = setSignFlag (HS.SigAll False) $ mkNoSigTxIn (HT.OutPoint ftiHash ftiOutIndex) (nonDusty ftiOutValue) - (Pay2 $ ScriptHash $ Cond cp) + cp -- If the sequence field equals maxBound (0xffffffff), -- lockTime features are disabled. so we subtract one refundIn = setSequence (maxBound-1) baseIn @@ -40,12 +38,12 @@ -> HC.Address -- ^Refund address -> SatoshisPerByte -- ^Refund transaction fee -> m (Either BtcError RefundTx) -- ^Refund Bitcoin transaction -mkRefundTx prvKey cp fti refundAddr txFee = - signSettleTx signFunc changeOut refundTx +mkRefundTx prvKey cp fti refundAddr txFee = return $ + runSimple prvKey $ signChangeTx refundTx changeOut where refundTx = mkBaseRefundTx cp fti changeOut = mkChangeOut refundAddr txFee KeepDust - signFunc _ = return prvKey +-- signFunc _ = return prvKey diff --git a/src/PaymentChannel/Internal/Settlement.hs b/src/PaymentChannel/Internal/Settlement.hs --- a/src/PaymentChannel/Internal/Settlement.hs +++ b/src/PaymentChannel/Internal/Settlement.hs @@ -3,50 +3,36 @@ -- ( -- createSignedSettlementTx -- , settleReceivedValue --- , UnsignedSettlementTx, mkUnsignedSettleData +-- , UnsignedSettlementTx, mkClientSignedSettleTx -- ) where import PaymentChannel.Internal.Settlement.Util import PaymentChannel.Internal.Receiver.Util -import PaymentChannel.Internal.Payment -import Bitcoin.Util -import Bitcoin.Types -import Bitcoin.Fee -import PaymentChannel.Types (fundingAddress) -import PaymentChannel.Internal.Class.Value (HasValue(..)) -import PaymentChannel.Internal.Error.Server - -import qualified Network.Haskoin.Transaction as HT -import qualified Network.Haskoin.Crypto as HC +import PaymentChannel.Internal.Error.Internal import qualified Data.List.NonEmpty as NE -{-# ANN module ("HLint: ignore Use mapMaybe"::String) #-} - -type SignedTx = BtcTx (P2SH ChanParams) PaymentScriptSig - +type SignedTx = BtcTx P2SH ChanParams PaymentScriptSig -mkUnsignedSettleData :: - NE.NonEmpty ServerPayChanX +mkClientSignedSettleTx :: + NE.NonEmpty (ServerPayChanI kd) -> [BtcOut] -> ClientSignedTx -mkUnsignedSettleData rpcL extraOuts = +mkClientSignedSettleTx rpcL extraOuts = txAddOuts extraOuts $ toClientSignedTx payLst where payLst = NE.map (pcsPayment . rpcState) rpcL - -getSignedSettlementTx :: Monad m => +getSignedSettlementTx :: + -- (MonadSign m signKey, MaybeKeyDeriveIndex kd) + HasSigningKey key P2SH ChanParams BtcSig => ServerPayChanI kd - -> (KeyDeriveIndex -> m HC.PrvKeyC) -- ^ Server/receiver's signing key. -> ChangeOut - -> m (Either ReceiverError SignedTx) -getSignedSettlementTx rpc signFunc chgOut = - let - dummyExtRPC = mkDummyExtendedRPC rpc :| [] - settleData = mkUnsignedSettleData dummyExtRPC [] - in - fmapL SettleError <$> signSettleTx signFunc chgOut settleData + -> SignM key (Either ReceiverError SignedTx) +getSignedSettlementTx rpc chgOut = + fmapL SettleSigningError <$> signChangeTx settleTx chgOut + where + settleTx = mkClientSignedSettleTx (rpc :| []) [] 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 @@ -25,12 +25,8 @@ { rssClientSig :: BtcSig } - -instance HasLockTimeDate (P2SH ChanParams) where - getLockTimeDate = cpLockTime . getCond - instance SpendFulfillment RefundScriptSig ChanParams where - rawSigs RefundScriptSig{..} MkChanParams{..} = + rawSigs RefundScriptSig{..} ChanParams{..} = [ (getPubKey cpReceiverPubKey, rssClientSig) ] signatureScript RefundScriptSig{..} _ = Script [ opPush rssClientSig @@ -38,7 +34,10 @@ -- Signal that we want to provide only one pubkey/sig pair (sender's), -- after it is checked that the lockTime has expired. - +instance HasSigner RefundScriptSig ChanParams where + signerPubKey = Tagged . getPubKey . cpSenderPubKey +instance TransformSigData RefundScriptSig () ChanParams where + mkSigData _ = Tagged . RefundScriptSig -- |After a settlement transaction is published, we save -- certain properties from the old state object before @@ -49,5 +48,5 @@ } deriving (Eq, Show, Generic, Serialize, FromJSON, ToJSON, NFData) +type ClientSignedTx = BtcTx P2SH ChanParams BtcSig -type ClientSignedTx = BtcTx (P2SH ChanParams) BtcSig diff --git a/src/PaymentChannel/Internal/Settlement/Util.hs b/src/PaymentChannel/Internal/Settlement/Util.hs --- a/src/PaymentChannel/Internal/Settlement/Util.hs +++ b/src/PaymentChannel/Internal/Settlement/Util.hs @@ -17,5 +17,5 @@ -infoFromState :: ServerPayChanI a -> SettleInfo +infoFromState :: ServerPayChanG kd sd -> SettleInfo infoFromState rpc = error "STUB" -- SettleInfo (error "STUB") (mdPayCount $ rpcMetadata rpc) diff --git a/src/PaymentChannel/Internal/State.hs b/src/PaymentChannel/Internal/State.hs deleted file mode 100644 --- a/src/PaymentChannel/Internal/State.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE RecordWildCards, TypeSynonymInstances #-} - -module PaymentChannel.Internal.State -( - module PaymentChannel.Internal.State -, module PaymentChannel.Internal.Types -) -where - -import PaymentChannel.Internal.Types -import PaymentChannel.Internal.Error -import PaymentChannel.Internal.Error.Status (checkReadyForPayment) --- import PaymentChannel.Internal.Payment -import Bitcoin.Util (addressToScriptPubKeyBS) -import PaymentChannel.Internal.ChanScript - -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 -import qualified Data.Serialize as Bin - - --- ########## --- ## Util ## --- ########## --- --- pcsFundingValue = ftiOutValue . pcsFundingTxInfo --- pcsValueTransferred cs = nonDusty (pcsFundingValue cs) - nonDusty (pcsClientChangeVal cs) --- pcsChannelValueLeft = pcsClientChangeVal --- pcsClientPubKey = cpSenderPubKey . pcsParameters --- pcsServerPubKey = cpReceiverPubKey . pcsParameters --- pcsDustLimit = configDustLimit --- pcsExpirationDate = cpLockTime . pcsParameters --- pcsClientChangeAddress = ptcSenderChangeAddress . pcsPaymentConfig --- pcsClientChangeScriptPubKey = addressToScriptPubKeyBS . pcsClientChangeAddress --- pcsLockTime = cpLockTime . pcsParameters --- pcsPrevOut (CPaymentChannelState _ (CFundingTxInfo h i _) _ _ _ _) = OutPoint h i --- --- pcsFundingSource :: PaymentChannelState -> HT.OutPoint --- pcsFundingSource pcs = HT.OutPoint (ftiHash fti) (ftiOutIndex fti) --- where fti = pcsFundingTxInfo pcs --- --- pcsGetPayment :: PaymentChannelState -> Payment --- 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 = --- pcs { pcsPaymentConfig = newPayConf } --- where newPayConf = pConf { ptcSenderChangeAddress = addr } --- --- setFundingSource :: PaymentChannelState -> FundingTxInfo -> PaymentChannelState --- setFundingSource pcs fti = --- pcs { pcsFundingTxInfo = fti } --- --- -- |We subtract the specified "dust" limit from the total available value. --- -- This avoids creating a Bitcoin transaction that won't circulate --- -- in the Bitcoin P2P network. --- channelValueLeft :: PaymentChannelState -> BtcAmount --- channelValueLeft pcs = --- nonDusty (pcsClientChangeVal pcs) - configDustLimit --- --- -- |Returns 'True' if all available channel value has been transferred, 'False' otherwise --- channelIsExhausted :: PaymentChannelState -> Bool --- channelIsExhausted pcs = --- bsSigFlag (pcsPaymentSignature pcs) == HS.SigNone True || --- channelValueLeft pcs == 0 - 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 @@ -2,26 +2,26 @@ {-# LANGUAGE DeriveGeneric, DeriveAnyClass, DataKinds #-} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} module PaymentChannel.Internal.Types -( - module PaymentChannel.Internal.Types - , module X - , module Network.Haskoin.Transaction - , module Network.Haskoin.Crypto - , module Network.Haskoin.Script - , module Data.List.NonEmpty - , module Control.Monad.Time - , Word32, Word64 +( module PaymentChannel.Internal.Types +, module X +, module Network.Haskoin.Transaction +, module Network.Haskoin.Crypto +, module Network.Haskoin.Script +, module Data.List.NonEmpty +, module Control.Monad.Time +, Word32, Word64, NFData ) where import PaymentChannel.Internal.Config as X import PaymentChannel.Internal.Util as X -import Bitcoin.Types as X +import Bitcoin.Types as X import PaymentChannel.Internal.ChanScript as X import PaymentChannel.Internal.Crypto.PubKey as X -import Bitcoin.SinglePair as X -import Bitcoin.SpendCond.Cond as X -import Bitcoin.LockTime.Util as X - +import Bitcoin.SinglePair as X +import Bitcoin.SpendCond.Cond as X +import Bitcoin.LockTime.Util as X +import PaymentChannel.Internal.Types.MonadConf as X +import Control.DeepSeq (NFData) import Network.Haskoin.Transaction hiding (signTx) @@ -31,16 +31,20 @@ import Network.Haskoin.Script import qualified Network.Haskoin.Transaction as HT import qualified Network.Haskoin.Crypto as HC -import qualified Network.Haskoin.Script as HS -import qualified Data.ByteString as B -import qualified Data.ByteString.Base16 as B16 + +import qualified Data.Serialize as Bin +import qualified Data.ByteString.Base16 as B16 import Data.Word import Data.List.NonEmpty (NonEmpty(..)) import GHC.Generics (Generic) import Data.Maybe (fromMaybe) import Control.Monad.Time -type Payment = SigSinglePair (P2SH ChanParams) + + +-- | The Bitcoin transaction script type we're using +--type ScriptType = ChanParams +type Payment = SigSinglePair P2SH ChanParams type SignedPayment = Payment BtcSig type UnsignedPayment = Payment () @@ -51,22 +55,49 @@ getLockTimeDate = cpLockTime . pairRedeemScript data PayChanState sigData = MkPayChanState - { pcsPayment :: Payment sigData - -- | SHA256 hash signature data of the opening channel payment (not including 'SigHash' flag). - -- Used as a shared client/server secret to - -- prevent denial-of-service attacks. - -- The resource, - -- that the client delivers payments to, may be publicly - -- accesible. Using this secret as part of the resource - -- identifier for the channel makes it very hard for outsiders - -- to guess valid resource identifiers, from looking at - -- in-blockchain data. - , pcsToken :: HC.Hash256 + { pcsPayment :: Payment sigData + -- | SHA256 hash of opening-channel-payment signature data ('BtcSig') (including 'SigHash' flag). + -- Used as a shared client/server secret to prevent denial-of-service attacks. + -- The resource, that the client delivers payments to, may be publicly + -- accesible. Using this secret as part of the resource identifier for + -- the channel makes it very hard for outsiders to guess valid resource + -- identifiers from looking at in-blockchain data. + , pcsSecret :: SharedSecret + -- |Various server-defined config options + , pcsSettings :: ServerSettings } deriving (Eq, Show, Typeable, Generic, Serialize, ToJSON, FromJSON, NFData) +instance HasLockTimeDate (PayChanState a) where + getLockTimeDate = getLockTimeDate . pcsPayment + +newtype SharedSecret = MkSharedSecret { ssHash :: HC.Hash256 } + deriving (Eq, Show, Typeable, Generic, Serialize, ToJSON, FromJSON, NFData) + +fromInitialPayment :: SigSinglePair t r BtcSig -> SharedSecret +fromInitialPayment = + MkSharedSecret . HC.hash256 . Bin.encode . getSigData + +fromHash :: HC.Hash256 -> SharedSecret +fromHash = MkSharedSecret + +toHash :: SharedSecret -> HC.Hash256 +toHash = ssHash + instance HasSendPubKey (PayChanState a) where getSendPubKey = getSendPubKey . pcsPayment instance HasRecvPubKey (PayChanState a) where getRecvPubKey = getRecvPubKey . pcsPayment +instance HasSigData PayChanState where + mapSigData f pcs@MkPayChanState{..} = + pcs { pcsPayment = + mapSigData f pcsPayment + } + +instance SetClientChangeAddr PayChanState where + _setClientChangeAddr pcs@MkPayChanState{..} addr = + pcs { pcsPayment = + _setClientChangeAddr pcsPayment addr + } + type EmptyClientPayChan = ClientPayChanI () type ClientPayChan = ClientPayChanI BtcSig @@ -74,19 +105,31 @@ data ClientPayChanI sigData = MkClientPayChan { -- |Internal state object spcState :: PayChanState sigData - , -- |Payment-signing function - spcPrvKey :: HC.PrvKeyC + -- |Payment-signing private key + , spcPrvKey :: HC.PrvKeyC } deriving (Eq, Typeable, Generic, NFData) instance HasSendPubKey (ClientPayChanI a) where getSendPubKey = getSendPubKey . spcState instance HasRecvPubKey (ClientPayChanI a) where getRecvPubKey = getRecvPubKey . spcState +instance HasSigData ClientPayChanI where + mapSigData f cpc@MkClientPayChan{..} = + cpc { spcState = + mapSigData f spcState + } + +instance SetClientChangeAddr ClientPayChanI where + _setClientChangeAddr cpc@MkClientPayChan{..} addr = + cpc { spcState = + _setClientChangeAddr spcState addr + } + -- |Holds information about the Bitcoin transaction used to fund -- the channel data FundingTxInfo = CFundingTxInfo { ftiHash :: HT.TxHash, -- ^ Hash of funding transaction. ftiOutIndex :: Word32, -- ^ Index/"vout" of funding output (zero-based index of funding output within list of transaction outputs) - ftiOutValue :: NonDusty BtcAmount -- ^ Value of funding output (channel max value). + ftiOutValue :: NonDustyAmount -- ^ Value of funding output (channel max value). } deriving (Eq, Show, Typeable, Generic) @@ -99,14 +142,12 @@ instance ToJSON FundingTxInfo instance FromJSON FundingTxInfo -ftiOutPoint :: FundingTxInfo -> HT.OutPoint -ftiOutPoint CFundingTxInfo{..} = HT.OutPoint ftiHash ftiOutIndex -instance ToJSON HC.Hash256 where - toJSON = String . cs . B16.encode . HC.getHash256 +-- instance ToJSON HC.Hash256 where +-- toJSON = String . cs . B16.encode . HC.getHash256 -instance FromJSON HC.Hash256 where - parseJSON = withText "Hash256" (either fail return . decode . fst . B16.decode . cs) +-- instance FromJSON HC.Hash256 where +-- parseJSON = withText "Hash256" (either fail return . decode . fst . B16.decode . cs) instance Show ClientPayChan where show (MkClientPayChan s _) = diff --git a/src/PaymentChannel/Internal/Types/Hour.hs b/src/PaymentChannel/Internal/Types/Hour.hs new file mode 100644 --- /dev/null +++ b/src/PaymentChannel/Internal/Types/Hour.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module PaymentChannel.Internal.Types.Hour where + +import PaymentChannel.Internal.Util +import Data.Word + +newtype Hour = MkHour { numHours :: Word32 } + deriving + ( Eq, Ord, Num, Enum, Real, Integral, Typeable + , Generic, Serialize, ToJSON, FromJSON, NFData + ) + +instance Show Hour where + show (MkHour h) + | h == 1 = "1 hour" + | otherwise = show h ++ " hours" + +toSeconds :: Num a => Hour -> a +toSeconds (MkHour i) = fromIntegral $ i * 3600 + + diff --git a/src/PaymentChannel/Internal/Types/MonadConf.hs b/src/PaymentChannel/Internal/Types/MonadConf.hs new file mode 100644 --- /dev/null +++ b/src/PaymentChannel/Internal/Types/MonadConf.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module PaymentChannel.Internal.Types.MonadConf where + +import Bitcoin.Types +import Control.Monad.Trans.Reader (Reader, runReader) +import Control.Monad.Reader +import PaymentChannel.Internal.Config + +newtype MonadConf a = MonadConf (Reader ServerSettings a) + deriving (Functor, Applicative, Monad, MonadReader ServerSettings) + +runConfM :: ServerSettings -> MonadConf a -> a +runConfM cfg (MonadConf r) = runReader r cfg + +instance HasConfDustLimit MonadConf where + confDustLimit = asks serverConfDustLimit + +instance HasConfSettlePeriod MonadConf where + confSettlePeriod = asks serverConfSettlePeriod 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 @@ -1,120 +1,27 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables, GeneralizedNewtypeDeriving #-} module PaymentChannel.Internal.Util -( - module PaymentChannel.Internal.Util --- , module Bitcoin.Util --- , module Bitcoin.LockTime.Types -, module Bin, module BinGet, module BinPut -, module JSON, module JSONT, module JSONUtil -, module Sci -, module Data.Maybe -, module Data.Either -, B.ByteString -, Generic -, NFData -, Typeable -, Int64 -, module Tagged -, cs -, fmapL -, (<>) -, module Ctrl +( module PaymentChannel.Internal.Util +, module Bitcoin.Internal.Util +, module JSONUtil ) where +import Bitcoin.Internal.Util 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 -import Data.Aeson as JSON hiding (Result(..), encode, decode) -import Data.Aeson.Types as JSONT hiding (Result(..)) -import Data.Scientific as Sci - -import Data.Monoid ((<>)) -import Data.Maybe -import Data.Either -import Data.Tagged as Tagged hiding (witness) -import qualified Data.ByteString.Base16 as B16 -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as C -import qualified Data.Text as T -import qualified Data.Aeson.Types as JSON -import Data.Int (Int64) -import Data.String.Conversions (cs) -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Data.EitherR (fmapL) -import Control.Monad as Ctrl (forM, mapM, (>=>), (<=<)) -import GHC.Generics (Generic) -import Data.Typeable (Typeable, typeOf) -import qualified Network.Haskoin.Crypto as HC - -toInt :: (Integral a, Num b) => a -> b -toInt = fromIntegral - - -getIndexSafe :: [a] -> Int -> Maybe a -getIndexSafe l i = if i < 0 || i+1 > length l then Nothing else Just $ l !! i - -toHexString :: B.ByteString -> String -toHexString = C.unpack . B16.encode - -toHexBS :: B.ByteString -> B.ByteString -toHexBS = B16.encode - -fromHexBS :: B.ByteString -> B.ByteString -fromHexBS = fst . B16.decode - -fromHexString :: String -> B.ByteString -fromHexString hexStr = - case (B16.decode . C.pack) hexStr of - (bs,e) -> - if B.length e /= 0 then B.empty else bs - -serialize :: Bin.Serialize a => a -> B.ByteString -serialize = Bin.encode - -deserEither :: forall a. (Typeable a, Bin.Serialize a) => B.ByteString -> Either String a -deserEither bs = do - let eitherRes' = BinGet.runGetPartial (Bin.get :: BinGet.Get a) bs - handleResult eitherRes' - where - handleResult eitherRes = case eitherRes of - BinGet.Done val _ -> Right val - BinGet.Partial feedFunc -> handleResult $ feedFunc B.empty - BinGet.Fail e leftoverBS -> Left $ - "Type: " ++ show (typeOf (undefined :: a)) ++ - ". Error: " ++ e ++ - ". Data consumed (" ++ show offset ++ " bytes): " ++ - toHexString (B.take offset bs) ++ - ". Unconsumed data: (" ++ show ( B.length bs - fromIntegral offset ) ++ - " bytes): " ++ - toHexString leftoverBS - where offset = B.length bs - B.length leftoverBS - -deserHex :: (Typeable a, Bin.Serialize a) => T.Text -> JSON.Parser a -deserHex = either - (fail . ("failed to decode hex: " ++)) return . - deserEither . fromHexBS . encodeUtf8 - -serHex :: Bin.Serialize a => a -> T.Text -serHex = decodeUtf8 . toHexBS . Bin.encode - - --- dummyPubkey :: HC.PubKeyC --- dummyPubkey = mkDummyPubkey "0323dcd0a7481cb90e3583923701b14d0b6757ebd76bf5b49e696c61f193d7a489" - -mkDummyPubkey :: B.ByteString -> HC.PubKeyC -mkDummyPubkey hexStr = - either (error "mkDummyPubkey: Invalid dummy pubkey data") id (Bin.decode pkBS) - where pkBS = fst $ B16.decode hexStr +-- MonadPast +import Data.Time.Clock.POSIX +import Control.Monad.Time +import Data.Functor.Identity +newtype MonadPast a = MonadPast (Identity a) + deriving (Functor, Applicative, Monad) -mkDummySig :: B.ByteString -> HC.Signature -mkDummySig hexStr = - fromMaybe (error "dummySig: Invalid dummy sig data") (HC.decodeDerSig sigBS) - where sigBS = fst $ B16.decode hexStr +instance MonadTime MonadPast where + currentTime = MonadPast $ Identity $ posixSecondsToUTCTime $ realToFrac 0 -dummySig = mkDummySig "304402204202cdb61cb702aa62de312a8e5eada817d90c4e26c8b696780b14d1576f204f02203c134d0acb057d917508ca9baab241a4f66ebea32f7acceeaf621a334927e17701" +-- | A 'MonadTime' result as if it were Jan 1 1970 +resultFromThePast :: MonadPast a -> a +resultFromThePast (MonadPast (Identity a)) = a +-- MonadPast diff --git a/src/PaymentChannel/RBPCP/Parse.hs b/src/PaymentChannel/RBPCP/Parse.hs new file mode 100644 --- /dev/null +++ b/src/PaymentChannel/RBPCP/Parse.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} +module PaymentChannel.RBPCP.Parse +( + fromPaymentData +, toPaymentData +, RBPCP.PaymentData(..) +, ParseError(..) +, parseRedeemScript +) +where + +import RBPCP.Types (PaymentData(..), JsonHex(..)) +import qualified RBPCP.Types as RBPCP +import PaymentChannel.Internal.Util +import PaymentChannel.Internal.Types +import qualified Network.Haskoin.Transaction as HT + + +data ParseError = + BadRedeemScript String + | BtcError BtcError + deriving (Eq, Generic, NFData, ToJSON, FromJSON, Serialize) + +toPaymentData :: Payment BtcSig -> PaymentData +toPaymentData (SigSinglePair input output) = + PaymentData + { paymentDataRedeemScript = JsonHex . RBPCP.BtcScript . getRedeemScript . btcCondScr $ input + , paymentDataFundingTxid = RBPCP.BtcTxId . HT.outPointHash . btcPrevOut $ input + , paymentDataFundingVout = HT.outPointIndex . btcPrevOut $ input + , paymentDataSignatureData = JsonHex . bsSig . btcSigData $ input + , paymentDataSighashFlag = JsonHex . bsSigFlag . btcSigData $ input + , paymentDataChangeValue = fromIntegral . nonDusty . btcAmount $ output + , paymentDataChangeAddress = btcAddress output + } + +fromPaymentData :: + HasConfDustLimit m + => BtcAmount + -> PaymentData + -> m (Either ParseError (Payment BtcSig)) +fromPaymentData fundVal pd = do + let inputE = paymentDataIn fundVal pd + outputE <- paymentDataOut pd + return $ do + input <- inputE + output <- outputE + Right $ SigSinglePair input output + +paymentDataIn :: BtcAmount -> PaymentData -> Either ParseError (InputG P2SH ChanParams BtcSig) +paymentDataIn fundVal pd@PaymentData{..} = + parseRedeemScript pd >>= Right . mapSigData (const paySig) . mkInput + where + mkInput r = mkNoSigTxIn prevOut fundVal r + prevOut = HT.OutPoint (RBPCP.btcTxId paymentDataFundingTxid) paymentDataFundingVout + -- TODO: strict DER/signature parsing + paySig = BtcSig (fromHex paymentDataSignatureData) + (fromHex paymentDataSighashFlag) + +parseRedeemScript :: PaymentData -> Either ParseError ChanParams +parseRedeemScript PaymentData{..} = + fmapL BadRedeemScript $ fromRedeemScript (RBPCP.bsGetScript $ fromHex paymentDataRedeemScript) + where + +paymentDataOut :: HasConfDustLimit m => PaymentData -> m (Either ParseError BtcOut) +paymentDataOut PaymentData{..} = + fmap (mkBtcOut paymentDataChangeAddress) . + fmapL BtcError <$> mkNonDusty outAmount + where + outAmount = fromIntegral paymentDataChangeValue :: BtcAmount + +instance Show ParseError where + show (BadRedeemScript str) = "bad redeemScript: " ++ show str + show (BtcError e) = "invalid Bitcoin transaction: " ++ show e diff --git a/src/PaymentChannel/Server.hs b/src/PaymentChannel/Server.hs new file mode 100644 --- /dev/null +++ b/src/PaymentChannel/Server.hs @@ -0,0 +1,155 @@ +module PaymentChannel.Server +( hasMinimumDuration +, channelFromInitialPayment +, acceptPayment +, acceptClosingPayment +, getSettlementBitcoinTx +, closedGetSettlementTx +, SettleTx +) where + +import PaymentChannel.Internal.Payment +import PaymentChannel.RBPCP.Parse +import PaymentChannel.Internal.Receiver.Util +import PaymentChannel.Internal.Receiver.Open (initialServerState) +import PaymentChannel.Internal.Settlement +import PaymentChannel.Types +import PaymentChannel.Internal.Error +import Control.Exception (throw) + +import qualified Network.Haskoin.Crypto as HC +import qualified Network.Haskoin.Transaction as HT +import Control.Monad.Trans.Either +-- import Control.Monad.Trans.Class (lift) + + +hasMinimumDuration :: + ( HasLockTimeDate lockTime, MonadTime m ) + => ServerSettings + -> lockTime + -> m (Either OpenError ()) +hasMinimumDuration ServerSettings{..} lt = do + hasMinDuration <- isLocked (toSeconds $ serverConfSettlePeriod + serverConfMinDuration) lt + return $ if hasMinDuration + then Right () + else Left $ InsufficientDuration serverConfMinDuration + +-- |Create new 'ServerPayChan' +channelFromInitialPayment :: + MonadTime m + => ServerSettings + -- ^ Derived from/matches the client's 'RBPCP.Types.FundingInfo' + -> HT.Tx + -- ^ Funding transaction + -> PaymentData + -- ^ Opening payment produced by client ('PaymentChannel.Client.channelWithInitialPayment') + -> m (Either PayChanError ServerPayChan) + -- ^ Server channel state +channelFromInitialPayment cfg@ServerSettings{..} tx paymentData = runEitherT $ do + initialState <- hoistEither $ fmapL OpenError $ initialServerState cfg tx paymentData + hoistEither =<< fmapL OpenError <$> hasMinimumDuration cfg initialState + hoistEither . checkOpenPrice =<< hoistEither =<< acceptPaymentInternal paymentData initialState + where + checkOpenPrice (state,val) = + if val /= serverConfOpenPrice + then Left $ OpenError $ IncorrectInitialPaymentValue $ val `FoundButExpected` serverConfOpenPrice + else Right state + +-- | Register, on the receiving side, a payment made by 'createPayment' 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. +-- | NB: Throws 'BadSignatureInState' on invalid old/in-state payment. +acceptPayment :: MonadTime m => + PaymentData -- ^Payment to verify and register + -> ServerPayChanI kd -- ^Receiver state object + -> m (Either PayChanError (ServerPayChanI kd, BtcAmount)) -- ^Value received plus new receiver state object +acceptPayment = acceptPaymentInternal + +acceptPaymentInternal :: + ( MonadTime m + , StateSignature sd + ) => + PaymentData -- ^Payment to verify and register + -> ServerPayChanG kd sd -- ^Receiver state object + -> m (Either PayChanError (ServerPayChanI kd, BtcAmount)) -- ^Value received plus new receiver state object +acceptPaymentInternal paymentData rpc = + either (return . Left) (acceptPaymentIgnoreStatus paymentData) (checkChannelStatus rpc) + +-- | Accept the payment that closes the payment channel. +-- The payment accepted here is allowed to have a different client change address +-- from that found in the state. +-- | NB: Throws 'BadSignatureInState' on invalid old/in-state payment. +acceptClosingPayment :: MonadTime m => + PaymentData -- ^Payment to verify and register + -> ServerPayChanI kd -- ^Receiver state object + -> m (Either PayChanError (ClosedServerChanI kd)) +acceptClosingPayment paymentData oldState = + fmap handleResult <$> acceptClosingPaymentInternal paymentData oldState + where + mkNewStatus newState = ChannelClosed $ getPayment newState + getPayment = pcsPayment . rpcState + handleResult (newState, _) = MkClosedServerChan + (setChannelStatus (mkNewStatus newState) oldState) + (getPayment newState) + +acceptPaymentIgnoreStatus :: + ( MonadTime m + , StateSignature sd + ) => + PaymentData -- ^Payment to verify and register + -> ServerPayChanG kd sd -- ^Receiver state object + -> m (Either PayChanError (ServerPayChanG kd BtcSig, BtcAmount)) -- ^Value received plus new receiver state object +acceptPaymentIgnoreStatus paymentData rpc@MkServerPayChan{..} = + either (return . Left) checkPayment (getPayment paymentData) + where + serverConf = pcsSettings rpcState + getPayment pd = fmapL RBPCPError $ runConfM serverConf $ fromPaymentData (getFundingAmount rpc) pd + mkReturnValue p val = (updateMetadata $ updState rpc p, val) + checkPayment p = do + valRecvdE <- paymentValueIncrease rpcState p + return $ mkReturnValue p <$> valRecvdE + +acceptClosingPaymentInternal :: + MonadTime m + => PaymentData -- ^Payment to verify and register + -> ServerPayChanI kd -- ^Receiver state object + -> m (Either PayChanError (ServerPayChanI kd, BtcAmount)) +acceptClosingPaymentInternal paymentData oldState = + acceptPaymentIgnoreStatus paymentData newChangeAddrState + where + newChangeAddrState = _setClientChangeAddr oldState (paymentDataChangeAddress paymentData) + + +-- |The value transmitted over the channel is settled when this transaction is in the Blockchain. +-- The receiver will want to make sure a transaction produced by this function +-- is included in a Bitcoin block before the refund transaction becomes valid (see 'getRefundBitcoinTx'). +-- The sender can only close the channel before expiration by requesting this transaction +-- from the receiver and publishing it to the Bitcoin network. +getSettlementBitcoinTx :: + ( HasSigningKey prvKey P2SH ChanParams BtcSig + , ChangeOutFee fee + ) => + ServerPayChanI kd -- ^ 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. + -> fee -- ^ Bitcoin transaction fee + -> DustPolicy -- ^ Whether to keep or drop receiver change output if below dust limit + -> SignM prvKey (Either ReceiverError SettleTx) -- ^ Settling Bitcoin transaction +getSettlementBitcoinTx rpc recvAdr txFee dp = + getSignedSettlementTx rpc (mkChangeOut recvAdr txFee dp) + +-- |Get the settlement tx for a 'ClosedServerChanI', where the closing payment +-- pays the Bitcoin transaction fee +closedGetSettlementTx :: + ( HasSigningKey prvKey P2SH ChanParams BtcSig + ) + => ClosedServerChanI a -- ^ Produced by 'acceptClosingPayment' + -> 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'). + -> DustPolicy -- ^ Whether to keep or drop receiver change output if below dust limit + -> SignM prvKey (Either ReceiverError SettleTx) -- ^ Settling Bitcoin transaction +closedGetSettlementTx MkClosedServerChan{..} recvAdr dp = do + let resE = resultFromThePast $ acceptClosingPaymentInternal (toPaymentData cscClosingPayment) cscState + (settleState,txFee) = either (throw . BadClosedServerChan) id resE + getSettlementBitcoinTx settleState recvAdr txFee dp + +{-# SPECIALIZE acceptPaymentInternal :: MonadTime m => PaymentData -> ServerPayChan -> m (Either PayChanError (ServerPayChan, BtcAmount)) #-} +{-# SPECIALIZE acceptPaymentInternal :: MonadTime m => PaymentData -> ServerPayChanX -> m (Either PayChanError (ServerPayChanX, BtcAmount)) #-} diff --git a/src/PaymentChannel/Test.hs b/src/PaymentChannel/Test.hs --- a/src/PaymentChannel/Test.hs +++ b/src/PaymentChannel/Test.hs @@ -1,51 +1,74 @@ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, DeriveGeneric, DeriveAnyClass #-} module PaymentChannel.Test -( - module PaymentChannel.Test - , module X -) - -where +( module PaymentChannel.Test +, module X +) where import PaymentChannel as X -import PaymentChannel.Types as X import PaymentChannel.Util as X import PaymentChannel.Internal.Receiver.Types as X -import PaymentChannel.Internal.ChanScript as X +import qualified RBPCP.Types as RBPCP import qualified Network.Haskoin.Crypto as HC +import qualified Network.Haskoin.Transaction as HT +import qualified Network.Haskoin.Script as HS +import qualified Data.ByteString.Char8 as C8 +import qualified Data.Serialize as Bin import Network.Haskoin.Test +import Data.Time.Clock.POSIX import Data.Time.Clock (UTCTime(..)) import Data.Time.Calendar (Day(..)) import Control.Monad (foldM) import Test.QuickCheck +import Debug.Trace +debugEnable = False +debugTrace str a = if debugEnable then trace str a else a maxCoins :: Integer -maxCoins = round $ (21e6 :: Double) * 1e8 +maxCoins = fromIntegral (maxBound :: BtcAmount) mIN_CHANNEL_SIZE :: BtcAmount -mIN_CHANNEL_SIZE = configDustLimit * 2 +mIN_CHANNEL_SIZE = testDustLimit * 2 +testDustLimit :: BtcAmount +testDustLimit = 6200 +testSettlePeriod :: Hour +testSettlePeriod = MkHour 12 + +testMinDuration :: Hour +testMinDuration = MkHour 48 + +mkTestServerConf :: BtcAmount -> ServerSettings +mkTestServerConf = ServerSettings + testDustLimit testSettlePeriod testMinDuration + + data ArbChannelPair = ArbChannelPair { sendChan :: ClientPayChan - , recvChan :: ServerPayChan + , recvChan :: ServerPayChanX , initPayAmount :: BtcAmount , initRecvAmount :: BtcAmount , initPayment :: SignedPayment - , recvPrvKey :: HC.PrvKeyC + , recvPrvKey :: TestRecvKey } deriving (Generic, NFData) +data TestRecvKey = TestRecvKey RootPrv (External ChildPair) + deriving (Generic, NFData) + +testPrvKeyC :: TestRecvKey -> HC.PrvKeyC +testPrvKeyC (TestRecvKey _ pair) = getKey pair + data ChannelPairResult = ChannelPairResult { resInitPair :: ArbChannelPair , resSendChan :: ClientPayChan - , resRecvChan :: ServerPayChan + , resRecvChan :: ServerPayChanX , resSentAmounts :: [BtcAmount] , resRecvdAmounts :: [BtcAmount] , resPayList :: [SignedPayment] - } deriving (Generic, NFData) + } deriving (Generic, NFData, Show) instance Show ArbChannelPair where show (ArbChannelPair spc rpc _ _ _ _) = @@ -58,26 +81,42 @@ instance Arbitrary ClientPayChan where arbitrary = fmap (sendChan . fst) mkChanPair -instance Arbitrary ServerPayChan where +instance Arbitrary ServerPayChanX where arbitrary = fmap (recvChan . fst) mkChanPair instance Arbitrary (PayChanState BtcSig) where - arbitrary = fmap rpcState (arbitrary :: Gen ServerPayChan) + arbitrary = fmap rpcState (arbitrary :: Gen ServerPayChanX) instance Arbitrary ChanParams where arbitrary = fmap fst mkChanParams -instance Arbitrary FundingTxInfo where - arbitrary = do - ArbitraryTxHash h <- arbitrary - i <- arbitrary - amt <- choose (fromIntegral mIN_CHANNEL_SIZE, maxCoins) - let fundAmount = either (error "Dust math fail") id $ mkNonDusty (fromIntegral amt :: BtcAmount) - return $ CFundingTxInfo h i fundAmount - instance Arbitrary BtcAmount where arbitrary = fromIntegral <$> choose (0, maxCoins) +instance Arbitrary NonDustyAmount where + arbitrary = arbitraryNonDusty 0 + +arbitraryNonDusty :: BtcAmount -> Gen NonDustyAmount +arbitraryNonDusty extraVal = do + val <- fromIntegral <$> choose (fromIntegral $ testDustLimit + extraVal, maxCoins) + either (\e -> error $ "Dusty amount: " ++ show val) return $ + runConfM (mkTestServerConf 0) $ mkNonDusty (val :: BtcAmount) + +genLockTimeDate + :: ServerSettings + -> UTCTime -- ^ Now-timestamp + -> Hour -- ^ Maximum duration + -> Gen LockTimeDate +genLockTimeDate ServerSettings{..} now maxDuration = do + let leeway = 6 :: Hour + maxTs = fromIntegral (maxBound :: Word32) + startTs = (round $ utcTimeToPOSIXSeconds now :: Integer) + + toSeconds (serverConfSettlePeriod + serverConfMinDuration + leeway) + timestamp <- choose (startTs, min (startTs + toSeconds maxDuration) maxTs) + either (const $ error $ "genLockTimeDate: bad logic: " ++ show timestamp) return $ + parseLockTime (fromIntegral timestamp) + + newtype NonZeroBitcoinAmount = NonZeroBitcoinAmount { getAmount :: BtcAmount } instance Arbitrary NonZeroBitcoinAmount where @@ -87,10 +126,25 @@ instance Arbitrary (Payment BtcSig) where arbitrary = snd <$> mkChanPair +-- -- Soft child keys (keys derivable from an XPubKey) have an index of less than 0x80000000 +--instance Arbitrary KeyDeriveIndex where +-- arbitrary = +-- fromMaybe (error "Bad key index") . mkKeyIndex <$> choose (0, 0x80000000 - 1) + instance MonadTime Gen where currentTime = return nowishTimestamp +instance Arbitrary RootPrv where + arbitrary = createRootPrv <$> arbitrary + +instance Arbitrary ByteString where + arbitrary = do + len <- choose (0,32) + c8Lst <- vector len + return $ C8.pack c8Lst + + toInitResult :: ArbChannelPair -> ChannelPairResult toInitResult initPair@(ArbChannelPair spc rpc payAmt rcvAmt pay _) = ChannelPairResult initPair spc rpc [payAmt] [rcvAmt] [pay] @@ -99,11 +153,11 @@ -- |Fold a payment of specified value into a 'ChannelPairResult' doPayment :: MonadTime m => ChannelPairResult -> BtcAmount -> m ChannelPairResult doPayment (ChannelPairResult initPair spc rpc sendList recvList payLst) amount = do - (newSpc, pmn, amountSent) <- cappedCreatePayment spc amount - eitherRpc <- acceptPayment rpc pmn + let (newSpc, pmn, amountSent) = createPaymentCapped spc (Capped amount) + eitherRpc <- ("doPayment send: " ++ show amountSent) `debugTrace` acceptPayment (toPaymentData pmn) rpc case eitherRpc of Left e -> error (show e) - Right (recvAmount, newRpc) -> return $ + Right (newRpc, recvAmount) -> return $ ("doPayment recv: " ++ show recvAmount) `debugTrace` ChannelPairResult initPair newSpc newRpc (amountSent : sendList) (recvAmount : recvList) @@ -111,40 +165,115 @@ runChanPair :: MonadTime m => ArbChannelPair -> [BtcAmount] -> m ChannelPairResult runChanPair chanPair paymentAmountList = + ("runChanPair lst: " ++ show paymentAmountList) `debugTrace` foldM doPayment (toInitResult chanPair) paymentAmountList -mkChanParams :: Gen (ChanParams, (HC.PrvKeyC, HC.PrvKeyC)) -mkChanParams = do +mkChanParams :: Gen (ChanParams, (HC.PrvKeyC, TestRecvKey)) +mkChanParams = arbitrary >>= fromRecvRootKey + +fromRecvRootKey :: RootPrv -> Gen (ChanParams, (HC.PrvKeyC, TestRecvKey)) +fromRecvRootKey recvRoot = do -- sender key pair ArbitraryPubKeyC sendPriv sendPK <- arbitrary -- receiver key pair - ArbitraryPubKeyC recvPriv recvPK <- arbitrary --- ArbitraryXPubKey recvPriv recvPK <- arbitrary + ArbitrarySoftPath arbPath <- arbitrary + let childPair = mkChild recvRoot arbPath :: External ChildPair + recvPK = getKey childPair -- TODO: Use a future expiration date for now - lockTime <- fromMaybe (error "Bad lockTime") . parseLockTime <$> choose (1795556940, maxBound) - return (MkChanParams - (MkSendPubKey sendPK) (MkRecvPubKey recvPK) lockTime, - (sendPriv, recvPriv)) + lockTime <- either (error "Bad lockTime") id . parseLockTime <$> choose (1795556940, maxBound) + return (ChanParams + (MkSendPubKey sendPK) (MkRecvPubKey $ HC.xPubKey recvPK) lockTime, + (sendPriv, TestRecvKey recvRoot childPair )) mkChanPair :: Gen (ArbChannelPair, SignedPayment) mkChanPair = arbitrary >>= mkChanPairInitAmount mkChanPairInitAmount :: BtcAmount -> Gen (ArbChannelPair, SignedPayment) mkChanPairInitAmount initPayAmount = do - (cp, (sendPriv, recvPriv)) <- mkChanParams - fti <- arbitrary - sendChanE <- channelWithInitialPayment sendPriv cp fti (getFundingAddress cp) initPayAmount + let testServerConf = mkTestServerConf initPayAmount + (cp, (sendPriv, recvKey@(TestRecvKey _ childPair))) <- mkChanParams + fundingVal <- arbitraryNonDusty $ max mIN_CHANNEL_SIZE (initPayAmount + testDustLimit) + (vout,tx) <- arbitraryFundingTx cp (nonDusty fundingVal) + let fundInfo = testRbpcpFundingInfo testServerConf cp initPayAmount + sendChanE = channelWithInitialPayment sendPriv (cpLockTime cp) (tx,vout) fundInfo let (sendChan,initPayment) = either (error . show) id sendChanE - recvChanE <- channelFromInitialPayment cp fti initPayment + + recvChanE <- channelFromInitialPayment testServerConf tx (toPaymentData initPayment) + let mkExtRPC chan = fromMaybe (error $ "mkExtendedKeyRPC failed. " ++ show (chan,childPair)) + $ mkExtendedKeyRPC chan (fromExternalPair childPair) case recvChanE of Left e -> error (show e) - Right (initRecvAmount,recvChan) -> return - (ArbChannelPair - --TODO: Cap initial payment amount - sendChan recvChan initRecvAmount initRecvAmount initPayment recvPriv - , initPayment) + Right recvChan -> return + ( ArbChannelPair + sendChan (mkExtRPC recvChan) initPayAmount initPayAmount initPayment recvKey + , initPayment) +testRbpcpFundingInfo :: + ServerSettings + -> ChanParams + -> BtcAmount -- ^ Open price + -> RBPCP.FundingInfo +testRbpcpFundingInfo ServerSettings{..} cp openPrice = + RBPCP.FundingInfo + { RBPCP.fundingInfoServerPubkey = RBPCP.Server . getPubKey . getRecvPubKey $ cp + , RBPCP.fundingInfoDustLimit = fromIntegral testDustLimit + , RBPCP.fundingInfoFundingAddressCopy = getFundingAddress cp + , RBPCP.fundingInfoOpenPrice = fromIntegral openPrice + , RBPCP.fundingInfoFundingTxMinConf = 0 + , RBPCP.fundingInfoSettlementPeriodHours = fromIntegral serverConfSettlePeriod + , RBPCP.fundingInfoMinDurationHours = fromIntegral serverConfMinDuration + } +-- Arbitrary range +--instance Arbitrary (BtcAmount,BtcAmount) where +-- arbitrary = do +-- arbMin <- arbitrary +-- arbMax <- choose (fromIntegral arbMin, maxCoins) +-- return (arbMin, fromIntegral arbMax) + +genRunChanPair :: Word -> (BtcAmount,BtcAmount) -> BtcAmount -> IO ChannelPairResult +genRunChanPair numPayments (rangeMin,rangeMax) initAmount = do + amountList <- fmap (map conv) <$> generate $ + vectorOf (conv numPayments) (choose (conv rangeMin, conv rangeMax) :: Gen Word64) + (arbPair,_) <- generate $ mkChanPairInitAmount initAmount + runChanPair arbPair amountList + where + conv :: (Integral a, Num b) => a -> b + conv = fromIntegral + +-- | Funding transaction with a funding output at an arbitrary output index +arbitraryFundingTx + :: ChanParams + -> BtcAmount -- ^ Funding amount + -> Gen (Word32, Tx) -- ^ Output index of funding output plus transaction +arbitraryFundingTx cp val = do + ArbitraryTx tx <- arbitrary + let mkP2shOut = Bin.encode . HS.encodeOutput . HS.PayScriptHash + out = HT.TxOut (fromIntegral val) (mkP2shOut $ getP2SHFundingAddress cp) + (idx,newOuts) <- arbitraryInsert (HT.txOut tx) out + let newTx = HT.createTx (HT.txVersion tx) (HT.txIn tx) newOuts (HT.txLockTime tx) + return (fromIntegral idx :: Word32, newTx) + +-- | Insert an element into a list at an arbitrary position +arbitraryInsert :: forall a. [a] -> a -> Gen (Int, [a]) +arbitraryInsert lst a = do + idx <- choose (0, length lst) + let (preLst,postLst) = splitAt idx lst + newLst = preLst ++ [a] ++ postLst + return (idx, newLst) + -- TODO: We don't bother testing expiration time for now nowishTimestamp :: UTCTime nowishTimestamp = UTCTime (ModifiedJulianDay 50000) 0 + + +createAcceptClosingPayment + :: ChangeOutFee fee + => HC.Address + -> fee + -> ChannelPairResult + -> Either PayChanError ClosedServerChanX +createAcceptClosingPayment addr fee ChannelPairResult{..} = + resultFromThePast $ acceptClosingPayment (toPaymentData closingPayment) resRecvChan + where + (_,closingPayment,_) = createClosingPayment resSendChan addr fee diff --git a/src/PaymentChannel/Types.hs b/src/PaymentChannel/Types.hs --- a/src/PaymentChannel/Types.hs +++ b/src/PaymentChannel/Types.hs @@ -8,8 +8,6 @@ -} -{-# LANGUAGE RecordWildCards, TypeSynonymInstances, FlexibleInstances #-} - module PaymentChannel.Types ( -- *Shared sender/receiver types/functions @@ -17,45 +15,43 @@ , ChanParams(..) , PaymentChannel(..), PayChan , PaymentChannelRecv(..) --- , getChannelFunding --- , getExpirationDate --- , getFundingAmount --- , getPaymentCount + , SharedSecret, HasSharedSecret(..), fromHash, toHash , fundingAddress , clientChangeAddress - , availableChannelVal --- , getNewestPayment --- , getNewestSig --- , senderChangeValue --- , channelValueLeft --- , chanIsExhausted --- , expiresBefore --- , getChannelState + , getFundingAmount - -- *Sender state + -- *Sender , ClientPayChanI(..) - -- *Receiver state - , ServerPayChan, ServerPayChanI(rpcMetadata) - , PayChanStatus(..) + -- *Receiver + , ServerPayChan, ServerPayChanG(rpcMetadata) + , PayChanStatus(..), MetadataI(..), OpenError(..) , S.getChannelStatus, S.setChannelStatus , S.markAsBusy, S.isReadyForPayment - + , ServerSettings(..), Hour(..) + -- *Receiver state (with pubkey metadata) , ServerPayChanX - , S.mkExtendedKeyRPC, S.metaKeyIndex + , S.mkExtendedKeyRPC --, S.metaKeyIndex +-- , KeyDeriveIndex +-- , mkKeyIndex, word32Index -- *Payment - , Payment --- , paySignature,payClientChange --- , FullPayment(..) + , SignedPayment + + -- *Receiver settlement + , ClosedServerChanI, ClosedServerChan, ClosedServerChanX + , getClosedState, cscClosingPayment + , SettleTx + -- **Error - , PayChanError(..) + , PayChanError(..), IsPayChanError(..) -- *Bitcoin - , BtcAmount - , BtcLockTime(..) + , module X , module Bitcoin.Fee + , PaymentValueSpec(..) + , Capped(..) -- *Crypto , SendPubKey(..),RecvPubKey(..),IsPubKey(..),HasSendPubKey(..),HasRecvPubKey(..) @@ -64,11 +60,8 @@ , module Bitcoin.SpendCond.Util , fromDate , getChanState --- , usesBlockHeight, dummyPayment - - -- *Config settings - , getSettlePeriod, getDustLimit - + , clientChangeVal + , toHaskoinTx ) where @@ -77,89 +70,67 @@ import PaymentChannel.Internal.Metadata.Util import PaymentChannel.Internal.Serialization () import PaymentChannel.Internal.Class.Value (HasValue(..)) +import PaymentChannel.Internal.Receiver.Open (OpenError(..)) import Bitcoin.SpendCond.Util +import Bitcoin.Types as X hiding (fromDate, KeyDeriveIndex, mkKeyIndex, word32Index) import qualified PaymentChannel.Internal.Receiver.Util as S import qualified PaymentChannel.Internal.ChanScript as Script -import PaymentChannel.Internal.Error (PayChanError(..)) +import PaymentChannel.Internal.Error import Bitcoin.Fee import qualified Network.Haskoin.Crypto as HC -import qualified Network.Haskoin.Transaction as HT -import Data.Word (Word64) -- |Both sender and receiver state objects have a 'PaymentChannelState' -class HasPayChanState a where - getPayChanState :: a -> PayChanState BtcSig +class HasSignedPayChanState a where + getChanState :: a -> PayChanState BtcSig --- getChannelFunding :: HasPayChanState a => a -> HT.OutPoint --- getChannelFunding = S.pcsFundingSource . getPayChanState --- --- getExpirationDate :: HasPayChanState a => a -> BtcLockTime --- getExpirationDate = S.pcsExpirationDate . getPayChanState --- --- getFundingAmount :: HasPayChanState a => a -> BtcAmount --- getFundingAmount = S.pcsFundingValue . getPayChanState +instance HasSignedPayChanState ClientPayChan where + getChanState = spcState --- getPaymentCount :: HasPayChanState a => a -> Word64 --- getPaymentCount = pcsPayCount . getPayChanState +instance HasSignedPayChanState (ServerPayChanI s) where + getChanState = rpcState + -fundingAddress :: HasPayChanState a => a -> HC.Address -fundingAddress = Script.getP2SHFundingAddress . pairRedeemScript . pcsPayment . getPayChanState +class HasPayChanState a where + getPayChanState :: a -> PayChanState () --- getNewestPayment :: HasPayChanState a => a -> Payment --- getNewestPayment pcs = S.pcsGetPayment (getPayChanState pcs) +instance HasPayChanState (ClientPayChanI a) where + getPayChanState = mapSigData (const ()) . spcState --- getNewestSig :: HasPayChanState a => a -> HC.Signature --- getNewestSig = bsSig . paySignature . getNewestPayment +instance HasPayChanState (ServerPayChanG kd a) where + getPayChanState = mapSigData (const ()) . rpcState + --- senderChangeValue :: HasPayChanState a => a -> BtcAmount --- senderChangeValue = pcsClientChangeVal . getPayChanState +getFundingAmount :: HasPayChanState a => a -> BtcAmount +getFundingAmount = fundingValue . pcsPayment . getPayChanState +fundingAddress :: HasPayChanState a => a -> HC.Address +fundingAddress = Script.getP2SHFundingAddress . pairRedeemScript . pcsPayment . getPayChanState + clientChangeAddress :: HasPayChanState a => a -> HC.Address clientChangeAddress = clientChangeAddr . pcsPayment . getPayChanState --- | Channel value left to send (subtracts dust limit from total available amount) -availableChannelVal :: HasPayChanState a => a -> BtcAmount -availableChannelVal a = clientChangeVal (pcsPayment $ getPayChanState a) - configDustLimit --- -- |Returns 'True' if all available channel value has been transferred, 'False' otherwise --- chanIsExhausted :: HasPayChanState a => a -> Bool --- chanIsExhausted = S.channelIsExhausted . getPayChanState - --- -- |Return True if channel expires earlier than given expiration date --- expiresBefore :: HasPayChanState a => BtcLockTime -> a -> Bool --- expiresBefore expDate chan = getExpirationDate chan < expDate - --- | Legacy -getChanState :: HasPayChanState a => a -> PayChanState BtcSig -getChanState = getPayChanState - -instance HasPayChanState ClientPayChan where - getPayChanState = spcState - -instance HasPayChanState (ServerPayChanI s) where - getPayChanState = rpcState - - -- |Get various information about an open payment channel. -class HasPayChanState a => PaymentChannel a where +class HasSignedPayChanState a => PaymentChannel a where -- |Get amount received by receiver/left for sender valueToMe :: a -> BtcAmount + -- |Remaining channel value + channelValueLeft :: a -> BtcAmount -- |For internal use - _setChannelState :: a -> PayChanState BtcSig -> a - --- clientChangeVal + getStatePayment :: a -> SignedPayment instance PaymentChannel ClientPayChan where valueToMe = clientChangeVal . pcsPayment . spcState - _setChannelState spc s = spc { spcState = s } + channelValueLeft = valueToMe + getStatePayment = pcsPayment . spcState instance PaymentChannel (ServerPayChanI s) where valueToMe (MkServerPayChan s _) = valueOf s - _setChannelState rpc s = rpc { rpcState = s } - + channelValueLeft = clientChangeVal . getStatePayment + getStatePayment = pcsPayment . rpcState -- |Payment channel state objects with metadata information class PaymentChannel a => PaymentChannelRecv a where @@ -170,7 +141,42 @@ clientTotalValueSent = metaTotalValXfer . rpcMetadata +class HasSharedSecret a where + getSecret :: a -> SharedSecret +instance HasSharedSecret (PayChanState a) where getSecret = pcsSecret +instance HasSharedSecret (ServerPayChanG sd s) where getSecret = getSecret . rpcState +instance HasSharedSecret ClientPayChan where getSecret = getSecret . spcState + -- |Short-hand class PaymentChannel a => PayChan a +instance HasFee fee => HasFee (Capped fee) where + absoluteFee availVal size (Capped fee) = + min availVal desiredFee + where + desiredFee = absoluteFee availVal size fee + +-- | Capped/non-capped amount-specifications (get value) +class PaymentValueSpec val where + paymentValue :: BtcAmount -- ^ Available value + -> ServerSettings + -> val -- ^ Payment value spec + -> BtcAmount -- ^ Actual payment amount + +---- | Capped/non-capped amount-specifications (make return type) +--class PaymentValueSpec val => PaymentValueRet val ret | ret -> val where +-- mkReturnVal :: Tagged val BtcAmount -- ^ Actual payment amount +-- -> Either BtcError SignedPayment -- ^ createPayment return value +-- -> ret -- ^ 'val'-specific return type + +newtype Capped val = Capped val + +instance PaymentValueSpec BtcAmount where + paymentValue _ = const id + +instance PaymentValueSpec (Capped BtcAmount) where + paymentValue valueAvailable ServerSettings{..} (Capped amt) = + if amt >= valueAvailable + then valueAvailable + else min amt (valueAvailable - serverConfDustLimit) diff --git a/test/BitcoinSpec.hs b/test/BitcoinSpec.hs new file mode 100644 --- /dev/null +++ b/test/BitcoinSpec.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module BitcoinSpec where + +import Bitcoin.Signature +import PaymentChannel.Test () +import Test.QuickCheck +import Test.Hspec +import Network.Haskoin.Test +import Data.Monoid ((<>)) +-- HELLO +import qualified Network.Haskoin.Crypto as HC +import qualified Network.Haskoin.Test as HC + + +newtype ArbitrarySpendCond = ArbitrarySpendCond ArbitraryScript + deriving (Eq, Show, Arbitrary) + +newtype ArbitrarySpendFulfill = ArbitrarySpendFulfill ArbitraryScript + deriving (Eq, Show, Arbitrary) + + +instance SpendCondition ArbitrarySpendCond where + conditionScript (ArbitrarySpendCond (ArbitraryScript s)) = s + +instance SpendFulfillment ArbitrarySpendFulfill ArbitrarySpendCond where + signatureScript (ArbitrarySpendFulfill (ArbitraryScript ss)) sc = + ss <> conditionScript sc + rawSigs = undefined + + +main :: IO () +main = hspec spec + +spec :: Spec +spec = + keySpec + +keySpec :: Spec +keySpec = do + describe "External ChildPub/ChildPair" $ + it "derive same pubkeys & created signatures verify" $ do + rootKey <- generate arbitrary + HC.ArbitrarySoftPath derivPath <- generate arbitrary + let pair :: External ChildPair + pair = mkChild (rootKey :: RootPrv) derivPath + pub :: External ChildPub + pub = mkChild (fromRootPrv rootKey) derivPath + (getKey pair :: HC.XPubKey) `shouldBe` (getKey pub :: HC.XPubKey) + HC.ArbitraryHash256 h256 <- generate arbitrary + -- External pair/pub compare + HC.signMsg h256 (getKey pair :: HC.PrvKeyC) `shouldSatisfy` + (\sig -> HC.verifySig h256 sig (getKey pub :: HC.PubKeyC)) + -- External pair/pair compare + HC.signMsg h256 (getKey pair :: HC.PrvKeyC) `shouldSatisfy` + (\sig -> HC.verifySig h256 sig (getKey pair :: HC.PubKeyC)) + describe "Internal ChildPair" $ + it "created signatures verify" $ do + rootKey <- generate arbitrary + HC.ArbitraryHardPath derivPath <- generate arbitrary + let pair :: Internal ChildPair + pair = mkChild (rootKey :: RootPrv) derivPath + HC.ArbitraryHash256 h256 <- generate arbitrary + -- Internal pair/pair compare + HC.signMsg h256 (getKey pair :: HC.PrvKeyC) `shouldSatisfy` + (\sig -> HC.verifySig h256 sig (getKey pair :: HC.PubKeyC)) + + +--btcSpec :: Spec +--btcSpec = +-- describe "Bitcoin" $ +-- it "signed transaction verifies" $ undefined + + +--serTest :: (Arbitrary a, Bin.Serialize a) +-- => Gen (Either String a) +--serTest = Bin.decode . Bin.encode <$> arbitrary diff --git a/test/DetDeriveSpec.hs b/test/DetDeriveSpec.hs new file mode 100644 --- /dev/null +++ b/test/DetDeriveSpec.hs @@ -0,0 +1,49 @@ +module DetDeriveSpec where + +--import Bitcoin.Internal.Types +import Bitcoin.BIP32.DetDerive +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Arbitrary +import qualified Network.Haskoin.Crypto as HC +import qualified Network.Haskoin.Test as HT +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString as BS + +newtype ArbRootPrv = ArbRootPrv RootPrv +instance Arbitrary ArbRootPrv where + arbitrary = do + ArbitraryDerivSeed bs <- arbitrary + return $ ArbRootPrv $ createRootPrv bs + +spec :: Spec +spec = describe "Deterministic key derivation" $ + it "derives same XPubKey for ChildPair & ChildPub" $ do + ArbRootPrv rootPrv <- generate arbitrary + arbSeed <- generate arbitrary + let pub = derivExtPub (fromRootPrv rootPrv) arbSeed + pair = derivExtPair rootPrv arbSeed + (getKey pub :: HC.XPubKey) `shouldBe` getKey pair + +derivExtPub + :: RootPub + -> ArbitraryDerivSeed + -> External ChildPub +derivExtPub = detDerive + +derivExtPair + :: RootPrv + -> ArbitraryDerivSeed + -> External ChildPair +derivExtPair = detDerive + +newtype ArbitraryDerivSeed = ArbitraryDerivSeed BS.ByteString + +instance Arbitrary ArbitraryDerivSeed where + arbitrary = do + len <- choose (0,32) + c8Lst <- vector len + return $ ArbitraryDerivSeed $ C8.pack c8Lst + +instance DerivationSeed ArbitraryDerivSeed where + toDerivSeed (ArbitraryDerivSeed bs) = bs diff --git a/test/Main.hs b/test/Main.hs deleted file mode 100644 --- a/test/Main.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards, GeneralizedNewtypeDeriving, DeriveFunctor #-} -module Main where - -import PaymentChannel.Test -import PaymentChannel.Util -import Bitcoin.SpendCond.Util - -import qualified Network.Haskoin.Transaction as HT -import qualified Network.Haskoin.Crypto as HC -import qualified Data.Aeson as JSON -import qualified Data.Serialize as Bin -import Data.Typeable -import Data.Maybe -import Data.Either - -import Test.Framework (Test, testGroup, defaultMain) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck -- (arbitrary) -import Test.QuickCheck.Monadic (monadic, run , assert) -import Test.QuickCheck.Property (Property) -import Control.Monad.Identity (Identity(Identity)) - -import Debug.Trace -{-# ANN module ("HLint: ignore Redundant if"::String) #-} - - -newtype TestM a = TestM { runTestId :: Identity a } - deriving (Functor, Applicative, Monad) - -instance MonadTime TestM where - currentTime = return nowishTimestamp - -runTestM :: forall c. TestM c -> c -runTestM = getIt . runTestId - where getIt (Identity a) = a - --- testAddrTestnet :: HC.Address --- testAddrTestnet = "2N414xMNQaiaHCT5D7JamPz7hJEc9RG7469" -testAddrLivenet :: HC.Address -testAddrLivenet = "14wjVnwHwMAXDr6h5Fw38shCWUB6RSEa63" - -recvSettleAddr :: HC.Address -recvSettleAddr = testAddrLivenet - -main :: IO () -main = putStrLn "" >> defaultMain tests - -tests :: [Test] -tests = - [ testGroup "Payment" - [ testGroup "State" - [ testProperty "Sender/receiver match" $ - testPaymentSessionM checkSendRecvStateMatch - , testProperty "Sent amount == received amount" $ - testPaymentSessionM checkRecvSendAmount - ] - , testGroup "Settlement tx" - [ testProperty "Sender value" $ - testPaymentSessionM checkSenderValue - , testProperty "Receiver value" $ - testPaymentSessionM checkReceiverValue - , testProperty "At least one output" $ - 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) - ] - ] - ] - -redeemScriptConversion :: ChanParams -> Bool -redeemScriptConversion cp = - case fromRedeemScript (getRedeemScript cp) of - Left e -> error (show cp ++ "\n\n" ++ show e) - Right r -> r == cp || error (show cp ++ "\n\n" ++ show r) - -- if r /= cp then error (show cp ++ "\n\n" ++ show r) else True - -indexOf :: HT.Tx -> HC.Address -> Maybe Int -indexOf tx addr = listToMaybe $ catMaybes $ zipWith f [0..] (HT.txOut tx) - where f idx out = - if HT.scriptOutput out == addressToScriptPubKeyBS addr - then Just idx - else Nothing - -mkSettleTx :: Monad m => - ChannelPairResult -> m Tx -mkSettleTx ChannelPairResult{..} = do - settleTxE <- getSettlementBitcoinTx - resRecvChan recvSettleAddr - (recvPrvKey resInitPair) (SatoshisPerByte 0) KeepDust - return $ either (error . show) id settleTxE - -checkSenderValue :: ChannelPairResult -> TestM Bool -checkSenderValue cpr@ChannelPairResult{..} = do - settleTx <- mkSettleTx cpr - let clientChangeOutIndex = indexOf settleTx (fundingAddress resSendChan) - clientChangeAmount = maybe 0 (HT.outValue . (HT.txOut settleTx !!)) clientChangeOutIndex - -- Check that the client change amount in the settlement transaction equals the - -- channel funding amount minus the sum of all payment amounts. - let fundingVal = fundingValue $ pcsPayment (getChanState resRecvChan) - fundValMinusPaym = fundingVal - fromIntegral (sum resSentAmounts) - return $ fromIntegral clientChangeAmount == fundValMinusPaym - -checkReceiverValue :: ChannelPairResult -> TestM Bool -checkReceiverValue cpr@ChannelPairResult{..} = do - settleTx <- mkSettleTx cpr - let recvOutIndex = indexOf settleTx recvSettleAddr - recvAmount = maybe 0 (HT.outValue . (HT.txOut settleTx !!)) recvOutIndex - -- Check receiver amount in settlement transaction with zero fee equals sum - -- of all payments. - return $ (fromIntegral recvAmount :: BtcAmount) == fromIntegral (sum resRecvdAmounts) - -alwaysOneOutput :: ChannelPairResult -> TestM Bool -alwaysOneOutput cpr = not . null . HT.txOut <$> mkSettleTx cpr - -checkSendRecvStateMatch :: ChannelPairResult -> TestM Bool -checkSendRecvStateMatch ChannelPairResult{..} = - return $ getChanState resSendChan == getChanState resRecvChan - -checkRecvSendAmount :: ChannelPairResult -> TestM Bool -checkRecvSendAmount ChannelPairResult{..} = - 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 - -> [BtcAmount] - -> Property -testPaymentSessionM testFunc arbChanPair payLst = - monadic runTestM $ - run (runChanPair arbChanPair payLst) >>= run . testFunc >>= assert - - --- testPaymentSessionM' :: --- (ChannelPairResult -> TestM Property) --- -> ArbChannelPair --- -> Property --- testPaymentSessionM' testFunc arbChanPair = --- monadic runTestM $ --- run (runChanPair arbChanPair) >>= run . testFunc - - -jsonSerDeser :: (Show a, Eq a, JSON.FromJSON a, JSON.ToJSON a) => a -> Bool -jsonSerDeser fp = - maybe False checkEquals decodedObj - where decodedObj = JSON.decode $ JSON.encode fp - 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 - - diff --git a/test/PayChanSpec.hs b/test/PayChanSpec.hs new file mode 100644 --- /dev/null +++ b/test/PayChanSpec.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE OverloadedStrings, RecordWildCards, GeneralizedNewtypeDeriving, DeriveFunctor #-} +module PayChanSpec where + +import PaymentChannel.Test + +import qualified Network.Haskoin.Transaction as HT +import qualified Network.Haskoin.Crypto as HC +import qualified Network.Haskoin.Test as HC +import qualified Network.Haskoin.Constants as HCC +import qualified Data.Aeson as JSON +import qualified Data.Serialize as Bin + +import Test.QuickCheck +import Test.QuickCheck.Monadic (monadic, run , assert) +import Test.QuickCheck.Property (Property) +import Control.Monad.Identity (Identity(Identity)) +import Test.Hspec + +import Debug.Trace +{-# ANN module ("HLint: ignore Redundant if"::String) #-} + + +newtype TestM a = TestM { runTestId :: Identity a } + deriving (Functor, Applicative, Monad) + +instance MonadTime TestM where + currentTime = return nowishTimestamp + +runTestM :: forall c. TestM c -> c +runTestM = getIt . runTestId + where getIt (Identity a) = a + +testAddr :: HC.Address +testAddr = if HCC.getNetwork == HCC.prodnet + then "14wjVnwHwMAXDr6h5Fw38shCWUB6RSEa63" + else "n2eMqTT929pb1RDNuqEnxdaLau1rxy3efi" + +recvSettleAddr :: HC.Address +recvSettleAddr = testAddr + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + paymentSpec + conversionSpec + +paymentSpec :: Spec +paymentSpec = + describe "Payment" $ + around withArbChanResult $ do + describe "Settlement tx" $ do + it "client change output amount equals funding value minus sum of payment values" $ \res -> do + let (changeAmount, fundValMinusPaySum, _) = runTestM $ checkSenderValue res + changeAmount `shouldBe` fundValMinusPaySum + it "receiver output amount equals sum of payment values" $ \res -> do + let (recvOutVal, paySumVal, _) = runTestM $ checkReceiverValue res + recvOutVal `shouldBe` paySumVal + it "always has at least one output" $ \res -> + runTestM (minOneOutput res) `shouldBe` True + describe "State" $ do + it "Sender/receiver match" + checkSendRecvStateMatch + it "Sent amounts == received amounts" + recvSendAmountsMatch + describe "Channel close" $ + it "Can produce & accept arbitrary closing payment with sane fee" $ \res -> do + HC.ArbitraryAddress arbAddr <- generate arbitrary + txFee <- fromIntegral <$> generate (choose (0 :: Word64, 10000)) + let closedStateE = createAcceptClosingPayment arbAddr (txFee :: SatoshisPerByte) res + closedStateE `shouldSatisfy` isRight + let Right closedState = closedStateE + HC.ArbitraryAddress arbServerAddr <- generate arbitrary +-- HC.ArbitraryPrvKeyC prvKey <- generate arbitrary + let settleTxE = runDummy $ closedGetSettlementTx closedState arbServerAddr DropDust + settleTxE `shouldSatisfy` isRight + +conversionSpec :: Spec +conversionSpec = do + describe "Conversion works for" $ + it "RedeemScript" $ generate arbitrary >>= + redeemScriptConversion + describe "Serialization works for" $ do + describe "JSON" $ do + it "Payment" $ generate arbitrary >>= + (jsonSerDeser :: Payment BtcSig -> IO ()) + it "ServerPayChan" $ generate arbitrary >>= + (jsonSerDeser :: ServerPayChanX -> IO ()) + describe "Binary" $ do + it "Payment" $ generate arbitrary >>= + (binSerDeser :: Payment BtcSig -> IO ()) + it "PayChanState" $ generate arbitrary >>= + (binSerDeser :: PayChanState BtcSig -> IO ()) + it "ChanParams" $ generate arbitrary >>= + (binSerDeser :: ChanParams -> IO ()) + +withArbChanResult :: (ChannelPairResult -> IO ()) -> IO () +withArbChanResult f = do + arbPair <- generate arbitrary + amtLst <- generate arbitrary + runChanPair arbPair amtLst >>= f + +redeemScriptConversion :: ChanParams -> IO () +redeemScriptConversion cp = + fromRedeemScript (getRedeemScript cp) `shouldBe` Right cp + +checkSenderValue :: ChannelPairResult -> TestM (BtcAmount, BtcAmount, HT.Tx) +checkSenderValue cpr@ChannelPairResult{..} = do + settleTx <- mkSettleTx cpr + let clientChangeOutIndex = indexOf settleTx (fundingAddress resSendChan) + clientChangeAmount = maybe 0 (HT.outValue . (HT.txOut settleTx !!)) clientChangeOutIndex + -- Check that the client change amount in the settlement transaction equals the + -- channel funding amount minus the sum of all payment amounts. + let fundingVal = fundingValue $ pcsPayment (getChanState resRecvChan) + fundValMinusPaym = fundingVal - fromIntegral (sum resSentAmounts) + return (fromIntegral clientChangeAmount, fundValMinusPaym, settleTx) + +checkReceiverValue :: ChannelPairResult -> TestM (BtcAmount, BtcAmount, HT.Tx) +checkReceiverValue cpr@ChannelPairResult{..} = do + settleTx <- mkSettleTx cpr + let recvOutIndex = indexOf settleTx recvSettleAddr + recvAmount = maybe 0 (HT.outValue . (HT.txOut settleTx !!)) recvOutIndex + -- Check receiver amount in settlement transaction with zero fee equals sum + -- of all payments. + return (fromIntegral recvAmount :: BtcAmount, fromIntegral (sum resRecvdAmounts), settleTx) + +minOneOutput :: ChannelPairResult -> TestM Bool +minOneOutput cpr = not . null . HT.txOut <$> mkSettleTx cpr + +checkSendRecvStateMatch :: ChannelPairResult -> IO () +checkSendRecvStateMatch ChannelPairResult{..} = + getChanState resSendChan `shouldBe` getChanState resRecvChan + +recvSendAmountsMatch :: ChannelPairResult -> IO () +recvSendAmountsMatch ChannelPairResult{..} = + resSentAmounts `shouldBe` resRecvdAmounts + + + +jsonSerDeser :: (Show a, Eq a, JSON.FromJSON a, JSON.ToJSON a) => a -> IO () +jsonSerDeser fp = + JSON.decode (JSON.encode fp) `shouldBe` Just fp + +binSerDeser :: (Typeable a, Show a, Eq a, Bin.Serialize a) => a -> IO () +binSerDeser fp = + deserEither (Bin.encode fp) `shouldBe` Right fp + + +testPaymentSessionM :: + (ChannelPairResult -> TestM Bool) + -> ArbChannelPair + -> [BtcAmount] + -> Property +testPaymentSessionM testFunc arbChanPair payLst = + monadic runTestM $ + run (runChanPair arbChanPair payLst) >>= run . testFunc >>= assert + + +indexOf :: HT.Tx -> HC.Address -> Maybe Int +indexOf tx addr = listToMaybe $ catMaybes $ zipWith f [0..] (HT.txOut tx) + where f idx out = + if HT.scriptOutput out == addressToScriptPubKeyBS addr + then Just idx + else Nothing + +mkSettleTx :: Monad m => + ChannelPairResult -> m Tx +mkSettleTx ChannelPairResult{..} = do + let prvKey = testPrvKeyC $ recvPrvKey resInitPair + let settleTxE = runSimple prvKey $ getSettlementBitcoinTx + resRecvChan recvSettleAddr + (SatoshisPerByte 0) KeepDust + return $ either (error . show) toHaskoinTx settleTxE diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/SpendCondSpec.hs b/test/SpendCondSpec.hs new file mode 100644 --- /dev/null +++ b/test/SpendCondSpec.hs @@ -0,0 +1,127 @@ +module SpendCondSpec +( main +, spec +) +where + +import Bitcoin.SpendCond.Cond +import Bitcoin.Util +import Bitcoin.Internal.Util + +import Test.Hspec +import Network.Haskoin.Script +import qualified Network.Haskoin.Script as HS + + + +data TestCond = TestCond -- ^ Test condition script + deriving Show +data TestFulfill = TestFulfill -- ^ Test fulfillment/signature script + +instance SpendCondition TestCond where + conditionScript _ = Script [ opPushData "TEST_SCRIPT" ] +instance SpendFulfillment TestFulfill TestCond where + signatureScript _ _ = Script [ opPushData "TEST_SIG" ] + rawSigs = undefined + +testPubKey = mkDummyPubkey "0323dcd0a7481cb90e3583923701b14d0b6757ebd76bf5b49e696c61f193d7a489" +testSig = mkDummySig "304402204202cdb61cb702aa62de312a8e5eada817d90c4e26c8b696780b14d1576f204f02203c134d0acb057d917508ca9baab241a4f66ebea32f7acceeaf621a334927e17701" +testBtcSig = BtcSig testSig (HS.SigAll False) + +fulfill = TestFulfill +testPKHSig = SpendPKH testBtcSig + +-- | For regular P2PKH we're using an actual condition/script, +-- but for P2WPKH it's just a template that's +-- handled as a special case by the script interpreter. +--p2pkh = Pay2 $ Cond $ PubkeyHash testPubKey +pkh = PubkeyHash testPubKey +--p2wpkh = Pay2 $ Witness $ PubkeyHash testPubKey +--p2wpkhINp2sh = Pay2 $ ScriptHash $ Witness $ PubkeyHash testPubKey + +--p2sh = Pay2 $ ScriptHash $ Cond TestCond + +--p2wsh = Pay2 $ Witness $ Cond TestCond +--p2wshINp2sh = Pay2 $ ScriptHash $ Witness $ Cond TestCond + +main :: IO () +main = hspec spec + +spec = spendCondSpec + +spendCondSpec :: Spec +spendCondSpec = + describe "Transaction script & witness" $ do + describe "P2PKH has correct" $ do + it "scriptPubKey" $ (scriptPubKey pkh :: TxOutputScript P2S) `shouldBe` + TxOutputScript [ OP_DUP + , OP_HASH160 + , opPush (hash160 testPubKey) + , OP_EQUALVERIFY + , OP_CHECKSIG + ] + it "scriptSig" $ (inputScript testPKHSig pkh :: TxInputScript P2S ) `shouldBe` + TxInputScript [ opPush testBtcSig, opPush testPubKey ] + it "witness" $ (witnessScript testPKHSig pkh :: WitnessScript P2S) `shouldBe` + WitnessScript mempty + + describe "P2SH has correct" $ do + it "scriptPubKey" $ (scriptPubKey TestCond :: TxOutputScript P2SH) `shouldBe` + TxOutputScript [ OP_HASH160 + , opPush $ hash160 (conditionScript TestCond) + , OP_EQUAL + ] + it "scriptSig" $ (inputScript fulfill TestCond :: TxInputScript P2SH) `shouldBe` + TxInputScript [ OP_PUSHDATA "TEST_SIG" OPCODE + , OP_PUSHDATA "\vTEST_SCRIPT" OPCODE + ] + it "witness" $ (witnessScript fulfill TestCond :: WitnessScript P2SH) `shouldBe` + WitnessScript mempty +{- + describe "P2WPKH has correct" $ do + it "scriptPubKey" $ scriptPubKey p2wpkh `shouldBe` + TxOutputScript [ OP_0 + , opPush (hash160 testPubKey) + ] + it "scriptSig" $ inputScript testPKHSig p2wpkh `shouldBe` + TxInputScript mempty + it "witness" $ witnessScript testPKHSig p2wpkh `shouldBe` + WitnessScript [ opPush testBtcSig, opPush testPubKey ] + + describe "P2WPKH in P2SH has correct" $ do + it "scriptPubKey" $ scriptPubKey p2wpkhINp2sh `shouldBe` + TxOutputScript [ OP_HASH160 + , OP_PUSHDATA "sA\SOH\aR\166\&1\196\182\178%\US\183[\177g^\158E\177" OPCODE + , OP_EQUAL + ] + it "scriptSig" $ inputScript testPKHSig p2wpkhINp2sh `shouldBe` + TxInputScript [ OP_PUSHDATA (serialize $ Script [ OP_0, opPush (hash160 testPubKey) ]) OPCODE ] + it "witness" $ witnessScript testPKHSig p2wpkhINp2sh `shouldBe` + WitnessScript [ opPush testBtcSig, opPush testPubKey ] + + describe "P2WSH has correct" $ do + it "scriptPubKey" $ scriptPubKey p2wsh `shouldBe` + TxOutputScript [ OP_0 + , opPush (hash256 $ conditionScript TestCond) + ] + it "scriptSig" $ inputScript fulfill p2wsh `shouldBe` + TxInputScript mempty + it "witness" $ witnessScript fulfill p2wsh `shouldBe` + WitnessScript [ OP_PUSHDATA "TEST_SIG" OPCODE + , OP_PUSHDATA "\vTEST_SCRIPT" OPCODE + ] + + describe "P2WSH in P2SH has correct" $ do + it "scriptPubKey" $ scriptPubKey p2wshINp2sh `shouldBe` + TxOutputScript [ OP_HASH160 + , OP_PUSHDATA "tq\233\219J\199\255\192C\177n\"\156U\171\233\151\206\188O" OPCODE + , OP_EQUAL + ] + it "scriptSig" $ inputScript fulfill p2wshINp2sh `shouldBe` + TxInputScript [ OP_PUSHDATA (serialize $ Script [ OP_0, opPush (hash256 $ conditionScript TestCond) ]) OPCODE ] + it "witness" $ witnessScript fulfill p2wshINp2sh `shouldBe` + WitnessScript [ OP_PUSHDATA "TEST_SIG" OPCODE + , OP_PUSHDATA "\vTEST_SCRIPT" OPCODE + ] +-} +