packages feed

bitcoin-payment-channel 0.1.0.0 → 0.1.1.0

raw patch · 12 files changed

+394/−124 lines, 12 filesdep +QuickCheckdep +aesondep +base64-bytestringdep ~basenew-component:exe:Test

Dependencies added: QuickCheck, aeson, base64-bytestring, bitcoin-payment-channel, scientific

Dependency ranges changed: base

Files

bitcoin-payment-channel.cabal view
@@ -1,5 +1,5 @@ name:                 bitcoin-payment-channel-version:              0.1.0.0+version:              0.1.1.0 synopsis:             Library for working with Bitcoin payment channels description:     A Bitcoin payment channel allows two parties two send value to each other very rapidly.@@ -39,17 +39,40 @@                         Data.Bitcoin.PaymentChannel.Internal.Settlement,                         Data.Bitcoin.PaymentChannel.Internal.State,                         Data.Bitcoin.PaymentChannel.Internal.Types,+                        Data.Bitcoin.PaymentChannel.Internal.Serialization,                         Data.Bitcoin.PaymentChannel.Internal.Util,                         Data.Bitcoin.PaymentChannel.Internal.Version -  ghc-options:          -fwarn-incomplete-patterns+--  ghc-options:          -Wall -  build-depends:        base >= 4.7 && < 5,+  build-depends:        base,                         bytestring, text, base16-bytestring, base58string, hexstring,+                        base64-bytestring,                         time,-                        cereal, binary,+                        cereal, binary, aeson, scientific,                         haskoin-core-   hs-source-dirs:       src++  default-language:     Haskell2010++executable Test+  main-is:              Main.hs++--  default-extensions:   FlexibleContexts++--  other-modules:++--  ghc-options:          -Wall++  build-depends:        base >= 4.7 && < 5,+                        bytestring, text, base16-bytestring, base58string, hexstring,+                        base64-bytestring,+                        time,+                        cereal, binary, aeson,+                        haskoin-core,+                        QuickCheck,+                        bitcoin-payment-channel++  hs-source-dirs:       test    default-language:     Haskell2010
src/Data/Bitcoin/PaymentChannel.hs view
@@ -47,11 +47,7 @@ The receiver will now create its own channel state object, 'ReceiverPaymentChannel', using  'channelFromInitialPayment'.  'channelFromInitialPayment' takes the same 'ChannelParameters' and 'FundingTxInfo'- as was provided by the sender, and, in addition, the receiver signing function- (used to produce the settlement transaction- that closes the payment channel), and the first channel 'Payment', received from the sender.- The receiver will want to use @flip 'Network.Haskoin.Crypto.signMsg' receiverPrivKey@ as the signing function,- where @<receiverPrivKey>@ is the private key from which 'cpReceiverPubKey' is derived.+ as was provided by the sender, and, in addition, the first channel 'Payment', received from the sender.  Now the payment channel is open and ready for transmitting value. A new 'Payment' is created by  the sender with 'sendPayment', which yields a new payment, that increases the total value transmitted@@ -66,10 +62,16 @@  transaction pays the total value transmitted over the channel to the receiver and the rest back  to the sender. +A settlement transaction can be produced by the value receiver using 'getSettlementBitcoinTx'.+ The receiver will want to use @flip 'Network.Haskoin.Crypto.signMsg' receiverPrivKey@ as the+ signing function passed to 'getSettlementBitcoinTx',+where @receiverPrivKey@ is the private key from which 'cpReceiverPubKey' is derived.++ __/IMPORTANT:/__ /Channel setup is risk free because the sender can derive a refund Bitcoin transaction/  /using 'getRefundBitcoinTx', which returns the bitcoins used to fund the channel back to the sender./  /This refund transaction, however, is not valid until the expiration date specified in 'ChannelParameters',/- /but it is paramount that the value receiver gets a settlement transaction included in a block/+ /but it is paramount that the value receiver get a settlement transaction included in a block/  /before the refund transaction becomes valid. Due to the fact that Bitcoin network time is allowed/  /to drift up to two hours from actual time, and the fact that finding new Bitcoin blocks does not occur/  /according to any schedule, it would be wise for the receiver to publish a settlement transaction at least/@@ -113,6 +115,7 @@  import qualified  Network.Haskoin.Crypto as HC import qualified  Network.Haskoin.Transaction as HT+import qualified  Network.Haskoin.Script as HS   -- |Create a new 'SenderPaymentChannel'.@@ -123,12 +126,13 @@     ChannelParameters -- ^ Specifies channel sender and receiver, plus channel expiration date     -> FundingTxInfo -- ^ Holds information about the transaction used to fund the channel     -> (HC.Hash256 -> HC.Signature) -- ^ See 'spcSignFunc'+    -> HC.Address   -- ^ Value sender/client change address     -> BitcoinAmount -- ^ Value of initial payment. Must be greater than or equal to 'minimumInitialPayment'     -> (Payment, SenderPaymentChannel) -- ^Initial payment and new sender state object channelWithInitialPaymentOf     cp@(CChannelParameters sendPK recvPK _)-    fundInf@(CFundingTxInfo hash idx chanVal) signFunc amount =-        let pConf = CPaymentTxConfig (bitcoinPayPKBS sendPK) (bitcoinPayPKBS recvPK) in+    fundInf@(CFundingTxInfo hash idx chanVal) signFunc sendAddr amount =+        let pConf = CPaymentTxConfig sendAddr in         sendPayment             (CSenderPaymentChannel (newPaymentChannelState cp fundInf pConf) signFunc)             amount@@ -169,16 +173,15 @@ channelFromInitialPayment ::     ChannelParameters -- ^ Specifies channel sender and receiver, plus channel expiration date     -> FundingTxInfo -- ^ Holds information about the transaction used to fund the channel-    -> (HC.Hash256 -> HC.Signature) -- ^ Function which produces a signature, over a hash, which verifies against 'cpReceiverPubKey'+    -> HC.Address   -- ^ Value sender/client change address     -> Payment -- ^Initial channel payment     -> Either PayChanError ReceiverPaymentChannel -- ^Receiver state object channelFromInitialPayment cp@(CChannelParameters sendPK recvPK _)-    fundInf signFunc paymnt =+    fundInf sendAddr paymnt =         let-            verifyFunc hash pk sig = HC.verifySig hash sig pk-            pConf = CPaymentTxConfig (bitcoinPayPKBS sendPK) (bitcoinPayPKBS recvPK)+            pConf = CPaymentTxConfig sendAddr             eitherNewState = flip recvPayment paymnt $ CReceiverPaymentChannel-                (newPaymentChannelState cp fundInf pConf) verifyFunc signFunc+                (newPaymentChannelState cp fundInf pConf)         in             mapRight snd eitherNewState @@ -189,7 +192,8 @@     ReceiverPaymentChannel -- ^Receiver state object     -> Payment -- ^Payment to verify and register     -> Either PayChanError (BitcoinAmount, ReceiverPaymentChannel) -- ^Value received plus new receiver state object-recvPayment rpc@(CReceiverPaymentChannel cs verifyFunc _) paymnt =+recvPayment rpc@(CReceiverPaymentChannel cs) paymnt =+    let verifyFunc hash pk sig = HC.verifySig hash sig pk in     if verifyPayment cs paymnt verifyFunc then         updatePaymentChannelState cs paymnt >>=         (\newState -> Right (pcsValueLeft cs - cpChannelValueLeft paymnt, rpc { rpcState = newState }))@@ -205,10 +209,12 @@ -- Returns NoValueTransferred if no payment has been received yet. getSettlementBitcoinTx ::     ReceiverPaymentChannel -- ^Receiver state object+    -> (HC.Hash256 -> HC.Signature) -- ^ Function which produces a signature, over a hash, which verifies against 'cpReceiverPubKey'+    -> HC.Address     -> BitcoinAmount -- ^Bitcoin transaction fee     -> Either PayChanError HT.Tx -- ^Settling Bitcoin transaction-getSettlementBitcoinTx (CReceiverPaymentChannel cs verifyFunc signFunc) txFee =-    getSignedSettlementTx cs txFee serverSig-        where serverSig = signFunc (getSettlementTxHashForSigning cs txFee)+getSettlementBitcoinTx (CReceiverPaymentChannel cs) signFunc recvAddr txFee =+    getSignedSettlementTx cs recvAddr txFee serverSig+        where serverSig = signFunc (getSettlementTxHashForSigning cs recvAddr txFee)
src/Data/Bitcoin/PaymentChannel/Internal/Payment.hs view
@@ -15,7 +15,7 @@ import Data.Maybe (fromJust, isJust) import qualified Data.ByteString as B -+---Payment Tx builer--- buildEmptyPaymentTx :: FundingTxInfo -> HT.Tx buildEmptyPaymentTx (CFundingTxInfo hash idx _) =     HT.Tx 1 --version 1@@ -24,24 +24,27 @@         (HT.OutPoint hash idx)         B.empty         maxBound]-    []-    0+    [] --no outputs+    0 --lockTime 0  paymentTxAddOutput :: HT.TxOut -> HT.Tx -> (HT.Tx, HS.SigHash) paymentTxAddOutput addOut tx@(HT.Tx _ _ outs _)-    | HT.outValue addOut >= dUST_LIMIT =+    | HT.outValue addOut >= fromIntegral dUST_LIMIT =         (tx { HT.txOut = outs ++ [addOut] }, HS.SigSingle True)     | otherwise =         (tx, HS.SigNone True)+---Payment Tx builer--- ++ getPaymentTxForSigning ::     PaymentChannelState     -> BitcoinAmount      -- ^New sender value (newValueLeft)     -> (HT.Tx, HS.SigHash) getPaymentTxForSigning st@(CPaymentChannelState _ fti-    (CPaymentTxConfig sendChg _) chanValLeft _) newValueLeft =+    (CPaymentTxConfig sendAddr) chanValLeft _) newValueLeft =         paymentTxAddOutput senderOut $ buildEmptyPaymentTx fti-            where senderOut = HT.TxOut (toWord64 newValueLeft) sendChg+            where senderOut = HT.TxOut (toWord64 newValueLeft) (addressToScriptPubKeyBS sendAddr)  getPaymentTxHashForSigning ::     PaymentChannelState@@ -52,6 +55,7 @@         (HS.txSigHash tx (getRedeemScript cp) 0 sigHash, sigHash)             where (tx,sigHash) = getPaymentTxForSigning st newValueLeft +---Payment build/verify--- verifyPayment ::     PaymentChannelState     -> Payment@@ -84,9 +88,9 @@             --sender has reliquished the remaining channel value,             -- due to it being below the "dust" limit.             HS.SigNone      _ -> CPayment 0 pSig-            HS.SigAll       _ -> error "BUG: unsupported SigHash"-            HS.SigUnknown _ _ -> error "BUG: unsupported SigHash"-+            _                 -> error+                "BUG: unsupported SigHash created by 'getPaymentTxHashForSigning'"+---Payment build/verify---
src/Data/Bitcoin/PaymentChannel/Internal/Script.hs view
@@ -3,12 +3,14 @@ module Data.Bitcoin.PaymentChannel.Internal.Script where  import Data.Bitcoin.PaymentChannel.Internal.Types+import Data.Bitcoin.PaymentChannel.Internal.Serialization import Data.Bitcoin.PaymentChannel.Internal.Util  import qualified  Network.Haskoin.Internals as HI import qualified  Network.Haskoin.Util as HU import qualified  Network.Haskoin.Crypto as HC import Network.Haskoin.Script+    (Script(..), SigHash(..), ScriptOp(..), opPushData)  import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C
+ src/Data/Bitcoin/PaymentChannel/Internal/Serialization.hs view
@@ -0,0 +1,99 @@+module Data.Bitcoin.PaymentChannel.Internal.Serialization where++import Data.Bitcoin.PaymentChannel.Internal.Types+import Data.Bitcoin.PaymentChannel.Internal.Util+    (BitcoinAmount(..), toWord64, deserEither, toHexString)++import            Data.Aeson (Value(Number), FromJSON(..), ToJSON(..),+                              withText, withScientific)+import            Data.Aeson.Types (Parser)+import            Data.Scientific (Scientific, scientific, toBoundedInteger)+import            Data.Text.Encoding       (decodeLatin1, encodeUtf8)+import            Data.ByteString.Lazy (toStrict, fromStrict)+import qualified  Data.Binary as Bin+import qualified  Data.Binary.Put as BinPut+import qualified  Data.Binary.Get as BinGet+import qualified  Data.ByteString.Base64 as B64++import Debug.Trace++++instance Show Payment where+    show (CPayment val sig) =+        "<Payment: valLeft=" ++ show val +++        ", sig=" ++ toHexString (toStrict $ Bin.encode sig) ++ ">"++-------JSON--------+instance ToJSON Payment where+    toJSON = toJSON . decodeLatin1 . B64.encode . toStrict . Bin.encode++instance FromJSON Payment where+    parseJSON = withText "Payment" $+        \b64 ->+            failOnLeftWith "failed to deserialize binary data: " =<<+            (\h -> show (toHexString h) `trace` binaryDeser h) =<<+            failOnLeftWith "failed to parse base64 data: " =<< b64Decode b64+        where+            b64Decode = return . B64.decode . encodeUtf8+            binaryDeser = return . deserEither+            failOnLeftWith e = either (fail . (e ++)) return++instance ToJSON BitcoinAmount where+    toJSON amt = Number $ scientific+        (fromIntegral $ toWord64 amt) 0++instance FromJSON BitcoinAmount where+    parseJSON = withScientific "BitcoinAmount" $+        fmap fromIntegral . parseJSONInt++-- Needed to convert from Scientific+instance Bounded BitcoinAmount where+    minBound = CMoneyAmount 0+    maxBound = CMoneyAmount $ round $ 21e6 * 1e8++parseJSONInt :: Scientific -> Parser Integer+parseJSONInt s =+    case toBoundedInteger s of+        Just (CMoneyAmount i) -> return i+        Nothing -> fail $ "failed to decode JSON number to integer. data: " ++ show s+++------BINARY--------+instance Bin.Binary PaymentChannelState where+    put (CPaymentChannelState par fti payConf valLeft (Just sig)) =+        Bin.put par >> Bin.put fti >> Bin.put payConf >> Bin.put valLeft+        >> BinPut.putWord8 1 >> Bin.put sig+    put (CPaymentChannelState par fti payConf valLeft Nothing) =+            Bin.put par >> Bin.put fti >> Bin.put payConf >> Bin.put valLeft+            >> BinPut.putWord8 0+    get = CPaymentChannelState <$> Bin.get <*> Bin.get <*>+        Bin.get <*> Bin.get <*> (BinGet.getWord8 >>=+        \w -> case w of+            1 -> fmap Just Bin.get+            _ -> return Nothing)++instance Bin.Binary ChannelParameters where+    put (CChannelParameters pks pkr lt) =+        Bin.put pks >> Bin.put pkr >> Bin.put lt+    get = CChannelParameters <$> Bin.get <*> Bin.get <*> Bin.get++instance Bin.Binary FundingTxInfo where+    put (CFundingTxInfo h idx val) =+        Bin.put h >> BinPut.putWord32be idx >> Bin.put val+    get = CFundingTxInfo <$> Bin.get <*> BinGet.getWord32be <*> Bin.get++instance Bin.Binary PaymentTxConfig where+    put (CPaymentTxConfig sendAddr) =+        Bin.put sendAddr+    get = CPaymentTxConfig <$> Bin.get++instance Bin.Binary Payment where+    put (CPayment val sig) = Bin.put val >> Bin.put sig+    get = CPayment <$> Bin.get <*> Bin.get++instance Bin.Binary PaymentSignature where+    put ps = Bin.put (psSig ps)+        >> Bin.put (psSigHash ps)+    get = CPaymentSignature <$> Bin.get <*> Bin.get+
src/Data/Bitcoin/PaymentChannel/Internal/Settlement.hs view
@@ -15,40 +15,43 @@  getSettlementTxForSigning ::     PaymentChannelState+    -> HC.Address     -> BitcoinAmount -- ^Bitcoin transaction fee for final payment transaction     -> (HT.Tx, HS.SigHash) -- ^ Transaction plus valueReceiver SigHash getSettlementTxForSigning st@(CPaymentChannelState _ fti@(CFundingTxInfo _ _ channelTotalValue)-    (CPaymentTxConfig sendChg recvChg) senderVal (Just (CPaymentSignature sig sigHash))) txFee =+    _ senderVal (Just (CPaymentSignature sig sigHash))) recvAddr txFee =         let             (baseTx,_) = getPaymentTxForSigning st senderVal             adjTx = if sigHash == HS.SigNone True then removeOutputs baseTx else baseTx             receiverAmount = channelTotalValue - senderVal - txFee -- may be less than zero-            recvOut = HT.TxOut (toWord64 receiverAmount) recvChg+            recvOut = HT.TxOut (toWord64 receiverAmount) (addressToScriptPubKeyBS recvAddr)         in             paymentTxAddOutput recvOut adjTx-getSettlementTxForSigning _ _ = error "no payment sig available"+getSettlementTxForSigning _ _ _ = error "no payment sig available"  getSettlementTxHashForSigning ::     PaymentChannelState+    -> HC.Address     -> BitcoinAmount -- ^Bitcoin transaction fee     -> HC.Hash256-getSettlementTxHashForSigning pcs@(CPaymentChannelState cp _ _ _ _) txFee =+getSettlementTxHashForSigning pcs@(CPaymentChannelState cp _ _ _ _) recvAddr txFee =     HS.txSigHash tx (getRedeemScript cp) 0 sigHash-        where (tx,sigHash) = getSettlementTxForSigning pcs txFee+        where (tx,sigHash) = getSettlementTxForSigning pcs recvAddr txFee  getSignedSettlementTx ::     PaymentChannelState-    -> BitcoinAmount      -- ^Bitcoin tx fee+    -> HC.Address       -- ^Receiver/server change address+    -> BitcoinAmount    -- ^Bitcoin tx fee     -> HC.Signature     -- ^Signature over 'getSettlementTxHashForSigning' which verifies against serverPubKey     -> Either PayChanError FinalTx getSignedSettlementTx pcs@(CPaymentChannelState-    cp@(CChannelParameters senderPK rcvrPK lt) _ _ _ (Just clientSig)) txFee serverRawSig =+    cp@(CChannelParameters senderPK rcvrPK lt) _ _ _ (Just clientSig)) recvAddr txFee serverRawSig =         let-            (tx,recvSigHash) = getSettlementTxForSigning pcs txFee+            (tx,recvSigHash) = getSettlementTxForSigning pcs recvAddr txFee             serverSig = CPaymentSignature serverRawSig recvSigHash             inputScript = getInputScript cp $ paymentTxScriptSig clientSig serverSig         in             Right $ replaceScriptInput (serialize inputScript) tx-getSignedSettlementTx (CPaymentChannelState _ _ _ _ Nothing) _ _ = Left NoValueTransferred+getSignedSettlementTx (CPaymentChannelState _ _ _ _ Nothing) _ _ _ = Left NoValueTransferred
src/Data/Bitcoin/PaymentChannel/Internal/State.hs view
@@ -4,18 +4,29 @@  import Data.Bitcoin.PaymentChannel.Internal.Types import Data.Bitcoin.PaymentChannel.Internal.Error+import Data.Bitcoin.PaymentChannel.Internal.Util  (addressToScriptPubKeyBS)  import qualified Network.Haskoin.Transaction as HT+import qualified Network.Haskoin.Crypto as HC  pcsChannelTotalValue = ftiOutValue . pcsFundingTxInfo pcsValueTransferred cs = pcsChannelTotalValue cs - pcsValueLeft cs pcsChannelValueLeft = pcsValueLeft pcsClientPubKey = cpSenderPubKey . pcsParameters pcsServerPubKey = cpReceiverPubKey . pcsParameters-pcsClientChange = ptcSenderChangeScript . pcsPaymentConfig-pcsServerChange = ptcReceiverChangeScript . pcsPaymentConfig+pcsClientChangeAddress = ptcSenderChangeAddress . pcsPaymentConfig+pcsClientChange = addressToScriptPubKeyBS . pcsClientChangeAddress pcsLockTime = cpLockTime . pcsParameters pcsChannelID = ftiHash . pcsFundingTxInfo++-- |Set new client/sender change address.+-- Use this function if the client wishes to change its change address.+-- First set the new change address using this function, then accept the payment which+-- uses this new change address.+setClientChangeAddress :: PaymentChannelState -> HC.Address -> PaymentChannelState+setClientChangeAddress pcs@(CPaymentChannelState _ _ pConf _ _) addr =+    pcs { pcsPaymentConfig = newPayConf }+        where newPayConf = pConf { ptcSenderChangeAddress = addr }   -- pcsChannelIsExhausted cs = maybe False (\pSig -> psSigHash pSig == ) (pcsPaymentSignature cs)
src/Data/Bitcoin/PaymentChannel/Internal/Types.hs view
@@ -12,7 +12,7 @@ import qualified  Data.Binary.Put as BinPut import qualified  Data.Binary.Get as BinGet -dUST_LIMIT = 700 :: Word64+dUST_LIMIT = 700 :: BitcoinAmount mIN_CHANNEL_SIZE = dUST_LIMIT * 2 pROTOCOL_VERSION = CVersion 2 0 @@ -21,17 +21,20 @@  -- |Shared state object used by both value sender and value receiver. data PaymentChannelState = CPaymentChannelState {+    -- |Defined by the sender and receiver     pcsParameters           ::  ChannelParameters,+    -- |Retrieved by looking at the in-blockchain funding transaction     pcsFundingTxInfo        ::  FundingTxInfo,+     pcsPaymentConfig        ::  PaymentTxConfig,-    -- |Value left to send+    -- |Value left to send (starts at @ftiOutValue . pcsFundingTxInfo@)     pcsValueLeft            ::  BitcoinAmount,     -- |Signature over payment transaction of value 'pcsValueLeft'     --  unless no payment has been made yet     pcsPaymentSignature     ::  Maybe PaymentSignature } deriving (Eq, Show) --- |Holds information about the channel+-- |Defines sender, receiver, and expiration date of the channel data ChannelParameters = CChannelParameters {     cpSenderPubKey      ::  HC.PubKey,     cpReceiverPubKey    ::  HC.PubKey,@@ -50,9 +53,9 @@ -- |Holds information about how to construct the payment transaction data PaymentTxConfig = CPaymentTxConfig {     -- |Value sender change scriptPubKey in Bitcoin payment transaction-    ptcSenderChangeScript   ::  B.ByteString,+    ptcSenderChangeAddress  ::  HC.Address     -- |Value receiver destination scriptPubKey in Bitcoin payment transaction-    ptcReceiverChangeScript ::  B.ByteString+--     ptcReceiverChangeScript ::  B.ByteString } deriving (Eq, Show)  -- |Used to transfer value from sender to receiver.@@ -61,54 +64,21 @@     cpChannelValueLeft ::  BitcoinAmount,     -- |Payment signature     cpSignature        ::  PaymentSignature-}+} deriving (Eq)  -- |Contains payment signature plus sig hash flag byte data PaymentSignature = CPaymentSignature {     psSig       ::  HC.Signature+    -- |SigHash flag. Denotes whether the sender still wants its change output+    --  included in the settling transaction. In case of (SigNone True), the+    --  value sender has given up the rest of the channel value, leaving+    --  everything to the receiver. This is necessary so that no settling+    --  transaction containing an output below the "dust limit" is produced.     ,psSigHash  ::  HS.SigHash } deriving (Eq, Show) -------SERIALIZATION-------- -instance Bin.Binary PaymentChannelState where-    put (CPaymentChannelState par fti payConf valLeft (Just sig)) =-        Bin.put par >> Bin.put fti >> Bin.put payConf >> Bin.put valLeft-        >> BinPut.putWord8 1 >> Bin.put sig-    put (CPaymentChannelState par fti payConf valLeft Nothing) =-            Bin.put par >> Bin.put fti >> Bin.put payConf >> Bin.put valLeft-            >> BinPut.putWord8 0-    get = CPaymentChannelState <$> Bin.get <*> Bin.get <*>-        Bin.get <*> Bin.get <*> (BinGet.getWord8 >>=-        \w -> case w of-            1 -> fmap Just Bin.get-            _ -> return Nothing) -instance Bin.Binary ChannelParameters where-    put (CChannelParameters pks pkr lt) =-        Bin.put pks >> Bin.put pkr >> Bin.put lt-    get = CChannelParameters <$> Bin.get <*> Bin.get <*> Bin.get--instance Bin.Binary FundingTxInfo where-    put (CFundingTxInfo h idx val) =-        Bin.put h >> BinPut.putWord32be idx >> Bin.put val-    get = CFundingTxInfo <$> Bin.get <*> BinGet.getWord32be <*> Bin.get--instance Bin.Binary PaymentTxConfig where-    put (CPaymentTxConfig sendScript recvScript) =-        Bin.put sendScript >> Bin.put recvScript-    get = CPaymentTxConfig <$> Bin.get <*> Bin.get--instance Bin.Binary PaymentSignature where-    put ps = Bin.put (psSig ps)-        >> Bin.put (psSigHash ps)-    get = CPaymentSignature <$> Bin.get <*> Bin.get--instance Bin.Binary Payment where-    put (CPayment val sig) = Bin.put val >> Bin.put sig-    get = CPayment <$> Bin.get <*> Bin.get-- -- Universally unique payment. -- Contains the necessary information to identify the channel -- over which the payment was sent, the signature (including SigHash flag)@@ -123,6 +93,3 @@ --     cpInfo          ::  Maybe BS.ByteString -- } -instance Show Payment where-    show (CPayment val sig) =-        "<Payment: valLeft=" ++ show val ++ ">"
src/Data/Bitcoin/PaymentChannel/Internal/Util.hs view
@@ -7,6 +7,8 @@ import qualified Data.Serialize.Put as SerPut (putWord64be) import qualified Data.Serialize.Get as SerGet (getWord64be) import qualified Data.Binary as Bin+import qualified Data.Binary.Put as BinPut+import qualified Data.Binary.Get as BinGet import Data.Binary.Put (putWord32le) import Data.Binary.Get (getWord32le, runGetOrFail) import Data.Word@@ -45,7 +47,7 @@ --  Integer operations will never over- or underflow with this type. --  Convert to a Word64 using 'toWord64', which caps the final amount. newtype BitcoinAmount = CMoneyAmount Integer-    deriving (Eq, Ord, Num, Enum, Real, Integral, Bin.Binary)+    deriving (Eq, Ord, Num, Enum, Real, Integral) instance Show BitcoinAmount where     show ma = show (fromIntegral $ toWord64 ma) ++ " satoshis" @@ -56,6 +58,10 @@         where             cappedValue = min i $ fromIntegral (maxBound :: Word64) +instance Bin.Binary BitcoinAmount where+    put = BinPut.putWord64le . toWord64+    get = CMoneyAmount . fromIntegral <$> BinGet.getWord64le+ instance Ser.Serialize BitcoinAmount where     put = SerPut.putWord64be . toWord64     get = CMoneyAmount . fromIntegral <$> SerGet.getWord64be@@ -75,6 +81,15 @@ p2SHAddressToScript addrStr =     HS.encodeOutput . HS.PayScriptHash <$> HC.base58ToAddr (C.pack addrStr) +addressToScript :: HC.Address -> HS.ScriptOutput+addressToScript addr =+    case addr of+        a@(HC.PubKeyAddress _) -> HS.PayPKHash a+        a@(HC.ScriptAddress _) -> HS.PayScriptHash a++addressToScriptPubKeyBS :: HC.Address -> B.ByteString+addressToScriptPubKeyBS = HS.encodeOutputBS . addressToScript+ serialize' :: Ser.Serialize a => a -> B.ByteString serialize' = Ser.encode @@ -110,7 +125,11 @@ --  Derive a 'BitcoinLockTime' from a 'Data.Time.Clock.UTCTime' using 'fromDate'. data BitcoinLockTime =     LockTimeBlockHeight Word32 |-    LockTimeDate UTCTime deriving (Eq, Show)+    LockTimeDate UTCTime deriving (Eq)++instance Show BitcoinLockTime where+    show (LockTimeBlockHeight blockNum) = "block number " ++ show blockNum+    show (LockTimeDate date) = show date  -- | Convert from Bitcoin format ('Word32') parseBitcoinLocktime :: Word32 -> BitcoinLockTime
src/Data/Bitcoin/PaymentChannel/Types.hs view
@@ -8,34 +8,66 @@  -} +{-# LANGUAGE GeneralizedNewtypeDeriving #-}+ module Data.Bitcoin.PaymentChannel.Types (+PaymentChannel(..), SenderPaymentChannel(..), ReceiverPaymentChannel(..), Payment, FundingTxInfo(..), ChannelParameters(..),-PayChanError,+PayChanError(..),+PaymentChannelState,  BitcoinAmount, toWord64,-PaymentChannel(..),-BitcoinLockTime, fromDate+BitcoinLockTime, fromDate,++-- Constants+dUST_LIMIT,+mIN_CHANNEL_SIZE ) where  import Data.Bitcoin.PaymentChannel.Internal.Types-    (PaymentChannelState(..), Payment-    ,FundingTxInfo(..), ChannelParameters(..))+    (PaymentChannelState(..), Payment(..)+    ,FundingTxInfo(..), ChannelParameters(..),+    dUST_LIMIT, mIN_CHANNEL_SIZE)+import Data.Bitcoin.PaymentChannel.Internal.Serialization+--     () import Data.Bitcoin.PaymentChannel.Internal.Util-    (BitcoinAmount, toWord64,+    (BitcoinAmount(..), toWord64,     BitcoinLockTime, fromDate)-import Data.Bitcoin.PaymentChannel.Internal.State (pcsChannelID, pcsChannelTotalValue)+import Data.Bitcoin.PaymentChannel.Internal.State (pcsChannelID, pcsChannelTotalValue,+                                                   setClientChangeAddress) import Data.Bitcoin.PaymentChannel.Internal.Error (PayChanError(..)) +import qualified  Data.Binary as Bin import qualified  Network.Haskoin.Crypto as HC import qualified  Network.Haskoin.Transaction as HT +-- |Get various information about an open payment channel.+class PaymentChannel a where+    -- |Get value sent to receiver/left for sender+    valueToMe           :: a -> BitcoinAmount+    channelValueLeft    :: a -> BitcoinAmount+    -- |Retrieve internal state object+    getChannelState     :: a -> PaymentChannelState+    -- |Get channel ID+    getChannelID        :: a -> HT.TxHash+    -- |Returns 'True' if all available channel value has been transferred, 'False' otherwise+    channelIsExhausted  :: a -> Bool+    -- |For internal use+    _setChannelState    :: a -> PaymentChannelState -> a +    channelValueLeft       = pcsValueLeft . getChannelState+    getChannelID           = pcsChannelID . getChannelState+    channelIsExhausted pch = pcsValueLeft (getChannelState pch) == 0 --TODO: payment sigHash == SigSingle++++ -- |State object for the value sender data SenderPaymentChannel = CSenderPaymentChannel {     -- |Internal state object@@ -47,45 +79,32 @@ }  -- |State object for the value receiver-data ReceiverPaymentChannel = CReceiverPaymentChannel {+newtype ReceiverPaymentChannel = CReceiverPaymentChannel {     -- |Internal state object-    rpcState        ::  PaymentChannelState,+    rpcState        ::  PaymentChannelState     -- |Used to verify signatures from value sender.-    rpcVerifyFunc   ::  HC.Hash256 -> HC.PubKey -> HC.Signature -> Bool,+--     rpcVerifyFunc   ::  HC.Hash256 -> HC.PubKey -> HC.Signature -> Bool     -- |Function which produces a signature that verifies against 'cpReceiverPubKey'.     --  Used to produce the Bitcoin transaction that closes the channel.-    rpcSignFunc     ::  HC.Hash256 -> HC.Signature-}---- |Get various information about an open payment channel.-class PaymentChannel a where-    -- |Get value sent to receiver/left for sender-    valueToMe           :: a -> BitcoinAmount-    -- |Retrieve internal channel state-    getChannelState     :: a -> PaymentChannelState-    -- |Get channel ID-    getChannelID        :: a -> HT.TxHash-    -- |Returns 'True' if all available channel value has been transferred, 'False' otherwise-    channelIsExhausted  :: a -> Bool--    getChannelID           = pcsChannelID . getChannelState-    channelIsExhausted pch = pcsValueLeft (getChannelState pch) == 0 --TODO: payment sigHash == SigSingle+--     rpcSignFunc     ::  HC.Hash256 -> HC.Signature+} deriving (Eq, Bin.Binary)  instance PaymentChannel SenderPaymentChannel where     valueToMe (CSenderPaymentChannel s _) =         pcsValueLeft s     getChannelState = spcState+    _setChannelState spc s = spc { spcState = s }  instance PaymentChannel ReceiverPaymentChannel where-    valueToMe (CReceiverPaymentChannel s _ _) =+    valueToMe (CReceiverPaymentChannel s) =         pcsChannelTotalValue s - pcsValueLeft s     getChannelState = rpcState-+    _setChannelState rpc s = rpc { rpcState = s }  instance Show SenderPaymentChannel where     show (CSenderPaymentChannel s _) =         "<SenderPaymentChannel:\n\t" ++ show s ++ ">"  instance Show ReceiverPaymentChannel where-    show (CReceiverPaymentChannel s _ _) =+    show (CReceiverPaymentChannel s) =         "<ReceiverPaymentChannel:\n\t" ++ show s ++ ">"
src/Data/Bitcoin/PaymentChannel/Util.hs view
@@ -11,23 +11,40 @@ module Data.Bitcoin.PaymentChannel.Util ( getFundingAddress,+setSenderChangeAddress, -BitcoinLockTime, parseBitcoinLocktime, toWord32, fromDate+BitcoinLockTime, parseBitcoinLocktime, toWord32, fromDate, deserEither ) where +import Data.Bitcoin.PaymentChannel.Internal.Types+    (PaymentChannelState(..), PaymentTxConfig(..))+-- import Data.Bitcoin.PaymentChannel.Internal.State+--     (ptcSenderChangeAddress) import Data.Bitcoin.PaymentChannel.Internal.Script     (getP2SHFundingAddress) import Data.Bitcoin.PaymentChannel.Internal.Util-    (BitcoinLockTime, parseBitcoinLocktime, toWord32, fromDate)+    (BitcoinLockTime, parseBitcoinLocktime, toWord32, fromDate, deserEither)+import Data.Bitcoin.PaymentChannel.Internal.State+    (setClientChangeAddress) --- Only used to make Haddock display the right link import Data.Bitcoin.PaymentChannel.Types-    (ChannelParameters, FundingTxInfo)+--     (ChannelParameters, FundingTxInfo) +import qualified Network.Haskoin.Crypto as HC+ -- | Derive a Bitcoin address, for funding a payment channel, from --  'ChannelParameters'. --  The transaction which pays to this address is the channel funding transaction, --  and information about this transaction is contained in --  'FundingTxInfo'. getFundingAddress = getP2SHFundingAddress++-- |Set new value sender change address+setSenderChangeAddress :: PaymentChannel a => a -> HC.Address -> a+setSenderChangeAddress pch addr =+    _setChannelState pch (setClientChangeAddress (getChannelState pch) addr)++++
+ test/Main.hs view
@@ -0,0 +1,100 @@+module Main where++import Data.Bitcoin.PaymentChannel+import Data.Bitcoin.PaymentChannel.Types+import Data.Bitcoin.PaymentChannel.Util+-- import Data.Bitcoin.PaymentChannel.Internal.Util++import qualified  Network.Haskoin.Transaction as HT+import qualified  Network.Haskoin.Crypto as HC+-- import Network.Haskoin.Test.Crypto+import Network.Haskoin.Test -- (ArbitraryHash256, ArbitraryTxHash(..))+import Network.Haskoin.Constants+import Data.Maybe+import Control.Monad++import Test.QuickCheck -- (elements, Gen, arbitrary, Property, quickCheck, (==>))+import Test.QuickCheck.Monadic -- (assert, monadicIO, pick, pre, run)+import Debug.Trace+++data ArbChannelPair = ArbChannelPair SenderPaymentChannel ReceiverPaymentChannel+    deriving (Show)++doPayment :: ArbChannelPair -> BitcoinAmount -> ArbChannelPair+doPayment (ArbChannelPair spc rpc) amount =+    let+        (pmn, newSpc) = sendPayment spc amount+        eitherRpc = recvPayment rpc pmn+    in+        case eitherRpc of+            Left e -> error (show e)+            Right (rAmt, newRpc) -> ArbChannelPair newSpc newRpc++instance Arbitrary ArbChannelPair where+    arbitrary = mkChanPair++mkChanPair :: Gen ArbChannelPair -- (Either String ArbChannelPair)+mkChanPair = do+        -- sender key pair+        ArbitraryPubKey sendPriv sendPK <- arbitrary+        -- receiver key pair+        ArbitraryPubKey recvPriv recvPK <- arbitrary+        -- expiration date+        lockTime <- arbitrary+        let cp = CChannelParameters sendPK recvPK lockTime++        fti <- arbitrary++        -- total channel value+        let chanAmount = fromIntegral $ ftiOutValue fti :: Integer+        -- value of first payment+        initPayAmount <- arbitrary -- fromIntegral <$> choose (0, chanAmount)++        let (paymnt,sendChan) = channelWithInitialPaymentOf+                cp fti (flip HC.signMsg sendPriv) (HC.pubKeyAddr sendPK) initPayAmount+        let eitherRecvChan = channelFromInitialPayment+                cp fti (HC.pubKeyAddr sendPK) paymnt++        case eitherRecvChan of+            Left e -> error (show e) --return $ Left (show e)+            Right recvChan -> return $ ArbChannelPair sendChan recvChan++instance Arbitrary BitcoinLockTime where+    arbitrary = fmap parseBitcoinLocktime arbitrary++instance Arbitrary FundingTxInfo where+    arbitrary = do+        ArbitraryTxHash h <- arbitrary+        i <- arbitrary+        amt <- fmap fromIntegral+            (choose (fromIntegral mIN_CHANNEL_SIZE, round $ 21e6 * 1e8 :: Integer))+            :: Gen BitcoinAmount+        return $ CFundingTxInfo h i amt++instance Arbitrary BitcoinAmount where+    arbitrary = fmap fromIntegral (choose (0,round $ 21e6 * 1e8 :: Integer))++runChanPair :: ArbChannelPair -> [BitcoinAmount] -> ArbChannelPair+runChanPair chanPair l = foldl doPayment chanPair l++checkChanPair :: ArbChannelPair -> Bool+checkChanPair (ArbChannelPair sendChan recvChan) =+    ("valLeft: " ++ show (valueToMe sendChan)) `trace`+        getChannelState recvChan == getChannelState sendChan+--     case getSettlementBitcoinTx sendChan 0 of+--         Left e -> False+--         Right tx -> True++testChanPair :: ArbChannelPair -> [BitcoinAmount] -> Bool+testChanPair p al = checkChanPair (runChanPair p al)++main :: IO ()+main = do+    quickCheckWith stdArgs -- { maxSuccess = 25 }+        testChanPair+--         (verbose $ testChanPair)++++