packages feed

bitcoin-payment-channel 0.6.0.1 → 1.0.0.0

raw patch · 71 files changed

+3672/−1869 lines, 71 filesdep +haskell-rbpcp-apidep +hspecdep +monad-timedep ~QuickCheckdep ~aesondep ~base16-bytestring

Dependencies added: haskell-rbpcp-api, hspec, monad-time, mtl, random, semigroups, tf-random

Dependency ranges changed: QuickCheck, aeson, base16-bytestring, bytestring, cereal, haskoin-core, hexstring, string-conversions, text, time

Files

bitcoin-payment-channel.cabal view
@@ -1,95 +1,138 @@-name:                 bitcoin-payment-channel-version:              0.6.0.1-synopsis:             Library for working with Bitcoin payment channels-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.-    This library implements a type of payment channel where channel setup-     is safe from transaction ID malleability, and value transfer is uni-directional (one party-     sends and the other party receives) (CHECKLOCKTIMEVERIFY-style).+-- This file has been generated from package.yaml by hpack version 0.14.0.+--+-- see: https://github.com/sol/hpack -author:         Rune K. Svendsen <runesvend@gmail.com>-maintainer:     Rune K. Svendsen <runesvend@gmail.com>-license:        PublicDomain+name:           bitcoin-payment-channel+version:        1.0.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.+                This library implements a type of payment channel where channel setup is safe from transaction ID malleability, and value transfer is uni-directional (one party sends and the other party receives) (CHECKLOCKTIMEVERIFY-style).+category:       Bitcoin, Finance, Network stability:      experimental homepage:       https://github.com/runeksvendsen/bitcoin-payment-channel bug-reports:    https://github.com/runeksvendsen/bitcoin-payment-channel/issues-category:       Bitcoin, Finance, Network+author:         Rune K. Svendsen <runesvend@gmail.com>+maintainer:     Rune K. Svendsen <runesvend@gmail.com>+license:        PublicDomain build-type:     Simple-cabal-version:  >=1.10+cabal-version:  >= 1.10  source-repository head-    type:     git-    location: git://github.com/runeksvendsen/bitcoin-payment-channel.git+  type: git+  location: git://github.com/runeksvendsen/bitcoin-payment-channel.git  library-  exposed-modules:      Data.Bitcoin.PaymentChannel-                        Data.Bitcoin.PaymentChannel.Types-                        Data.Bitcoin.PaymentChannel.Util-                        Data.Bitcoin.PaymentChannel.Test--  other-modules:        Data.Bitcoin.PaymentChannel.Internal.State-                        Data.Bitcoin.PaymentChannel.Internal.Error-                        Data.Bitcoin.PaymentChannel.Internal.Payment-                        Data.Bitcoin.PaymentChannel.Internal.Refund-                        Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Amount-                        Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Script-                        Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Util-                        Data.Bitcoin.PaymentChannel.Internal.Bitcoin.LockTime-                        Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Fee-                        Data.Bitcoin.PaymentChannel.Internal.Crypto.PubKey-                        Data.Bitcoin.PaymentChannel.Internal.Settlement-                        Data.Bitcoin.PaymentChannel.Internal.Types-                        Data.Bitcoin.PaymentChannel.Internal.Serialization-                        Data.Bitcoin.PaymentChannel.Internal.Util---  ghc-options:          -Wall-  default-language:     Haskell2010--  build-depends:        base                >= 4.7    && < 5,-                        haskoin-core        >= 0.4.0  && < 0.5.0,-                        base16-bytestring   >= 0.1.0  && < 0.2.0,-                        bytestring          >= 0.10.0 && < 0.11.0,-                        cereal              >= 0.5.0  && < 0.6.0,-                        errors              >= 2.0.0  && < 2.2.0,-                        hexstring           >= 0.11.0 && < 0.12.0,-                        text                >= 1.2.0  && < 1.3.0,-                        time                >= 1.5.0  && < 1.7.0,-                        aeson               >= 0.11.0 && < 0.12.0,-                        scientific          >= 0.3.0  && < 0.4.0,-                        string-conversions  >= 0.4    && < 0.5,-                        tagged              >= 0.8    && < 1.0,-                        QuickCheck          >= 2.8    && < 2.9--  hs-source-dirs:       src-+  hs-source-dirs:+      src+  default-extensions: OverloadedStrings RecordWildCards MultiParamTypeClasses TypeSynonymInstances FlexibleInstances FlexibleContexts FunctionalDependencies DataKinds ScopedTypeVariables+  ghc-options: -W+  build-depends:+      base                >=4.7     && <5+    , haskoin-core        >=0.4.0   && <0.5.0+    , haskell-rbpcp-api+    , base16-bytestring   >=0.1.0   && <0.2.0+    , bytestring          >=0.10.0  && <0.11.0+    , cereal              >=0.5.0   && <0.6.0+    , errors              >=2.0.0   && <2.2.0+    , hexstring           >=0.11.0  && <0.12.0+    , text                >=1.2.0   && <1.3.0+    , time                >=1.5.0   && <1.7.0+    , aeson               >=0.11.0  && <1.1+    , scientific          >=0.3.0   && <0.4.0+    , string-conversions  >=0.4     && <0.5+    , tagged              >=0.8     && <1.0+    , semigroups          >=0.17    && <0.19+    , QuickCheck          >=2.8     && <2.10+    , monad-time          ==0.2+    , hspec+  exposed-modules:+      PaymentChannel+      PaymentChannel.Types+      PaymentChannel.Util+      PaymentChannel.Test+  other-modules:+      Bitcoin.Amount+      Bitcoin.Compare+      Bitcoin.Config+      Bitcoin.Conversion+      Bitcoin.Dust+      Bitcoin.Error+      Bitcoin.Fee+      Bitcoin.LockTime.Types+      Bitcoin.LockTime.Util+      Bitcoin.Orphans+      Bitcoin.Signature+      Bitcoin.SinglePair+      Bitcoin.SpendCond.Cond+      Bitcoin.SpendCond.Spec+      Bitcoin.Tx+      Bitcoin.Types+      Bitcoin.Util+      PaymentChannel.Internal.ChanScript+      PaymentChannel.Internal.Class.Value+      PaymentChannel.Internal.Config+      PaymentChannel.Internal.Crypto.PubKey+      PaymentChannel.Internal.Error+      PaymentChannel.Internal.Error.Server+      PaymentChannel.Internal.Error.Status+      PaymentChannel.Internal.Error.User+      PaymentChannel.Internal.Metadata.Types+      PaymentChannel.Internal.Metadata.Util+      PaymentChannel.Internal.Payment+      PaymentChannel.Internal.Payment.Create+      PaymentChannel.Internal.Payment.Types+      PaymentChannel.Internal.Payment.Verify+      PaymentChannel.Internal.RBPCP.Parse+      PaymentChannel.Internal.Receiver.Settle+      PaymentChannel.Internal.Receiver.Types+      PaymentChannel.Internal.Receiver.Util+      PaymentChannel.Internal.Refund+      PaymentChannel.Internal.Serialization+      PaymentChannel.Internal.Serialization.JSON+      PaymentChannel.Internal.Serialization.Orphans+      PaymentChannel.Internal.Settlement+      PaymentChannel.Internal.Settlement.Config+      PaymentChannel.Internal.Settlement.Script+      PaymentChannel.Internal.Settlement.Types+      PaymentChannel.Internal.Settlement.Util+      PaymentChannel.Internal.State+      PaymentChannel.Internal.Types+      PaymentChannel.Internal.Util+      Paths_bitcoin_payment_channel+  default-language: Haskell2010  test-suite test-bitcoin-payment-channel   type: exitcode-stdio-1.0   main-is: Main.hs-  default-language:     Haskell2010-  hs-source-dirs: test-  ghc-options:    -Wall--  build-depends:        base                >= 4.7   && < 5,-                        haskoin-core        >= 0.4.0 && < 1.0.0,-                        QuickCheck          >= 2.8    && < 2.9,--                        bytestring,-                        base16-bytestring, base64-bytestring,-                        hexstring, text,-                        string-conversions,-                        time,-                        cereal, aeson,--                        test-framework, test-framework-quickcheck2,-                        bitcoin-payment-channel+  hs-source-dirs:+      test+  default-extensions: OverloadedStrings RecordWildCards MultiParamTypeClasses TypeSynonymInstances FlexibleInstances FlexibleContexts FunctionalDependencies DataKinds ScopedTypeVariables+  ghc-options: -Wall+  build-depends:+      base                >=4.7     && <5+    , haskoin-core        >=0.4.0   && <0.5.0+    , haskell-rbpcp-api+    , base16-bytestring   >=0.1.0   && <0.2.0+    , bytestring          >=0.10.0  && <0.11.0+    , cereal              >=0.5.0   && <0.6.0+    , errors              >=2.0.0   && <2.2.0+    , hexstring           >=0.11.0  && <0.12.0+    , text                >=1.2.0   && <1.3.0+    , time                >=1.5.0   && <1.7.0+    , aeson               >=0.11.0  && <1.1+    , scientific          >=0.3.0   && <0.4.0+    , string-conversions  >=0.4     && <0.5+    , tagged              >=0.8     && <1.0+    , semigroups          >=0.17    && <0.19+    , QuickCheck          >=2.8     && <2.10+    , monad-time          ==0.2+    , hspec+    , bitcoin-payment-channel+    , base64-bytestring+    , test-framework+    , test-framework-quickcheck2+    , tf-random+    , random+    , mtl+  default-language: Haskell2010
+ src/Bitcoin/Amount.hs view
@@ -0,0 +1,72 @@+module Bitcoin.Amount+(+  BtcAmount+)++where++import           PaymentChannel.Internal.Util+import           Data.Word+import           Data.Ratio+++-- |Represents a bitcoin amount as number of satoshis.+--  1 satoshi = 1e-8 bitcoin. 1e8 satohis = 1 bitcoin.+--  Only amounts >= 0 can be represented, and 'fromInteger' caps to a 'Word64'.+--  It is thus not possible to eg. construct a negative BtcAmount which, when added to+--  another BtcAmount, subtracts from its value. Adding two large amounts together will+--  never overflow, nor will subtraction underflow.+newtype BtcAmount = MkBitcoinAmount Word64+    deriving (Eq, Ord)+instance Show BtcAmount where+    show amount = show (toInteger amount) ++ " satoshi"++instance Num BtcAmount where+    (MkBitcoinAmount a1) * (MkBitcoinAmount a2) = mkCapped $ fromIntegral a1 * fromIntegral a2+    (MkBitcoinAmount a1) + (MkBitcoinAmount a2) = mkCapped $ fromIntegral a1 + fromIntegral a2+    (MkBitcoinAmount a1) - (MkBitcoinAmount a2) = mkCapped $ fromIntegral a1 - fromIntegral a2+    abs = id    -- Always positive+    signum (MkBitcoinAmount 0) = MkBitcoinAmount 0+    signum (MkBitcoinAmount _) = MkBitcoinAmount 1+    fromInteger = mkCapped++instance Enum BtcAmount where+    toEnum = mkCapped . fromIntegral+    fromEnum (MkBitcoinAmount amount) = fromIntegral amount++instance Real BtcAmount where+    toRational (MkBitcoinAmount amount) = toRational amount++instance Integral BtcAmount where+    toInteger (MkBitcoinAmount int) = fromIntegral int+    quotRem (MkBitcoinAmount a1) (MkBitcoinAmount a2) =+        (mkCapped res1, mkCapped res2)+            where (res1,res2) = quotRem (fromIntegral a1) (fromIntegral a2)++instance Bounded BtcAmount where+    minBound = MkBitcoinAmount 0+    maxBound = MkBitcoinAmount $ round $ (21e6 :: Ratio Integer) * (1e8 :: Ratio Integer)++mkCapped :: Integer -> BtcAmount+mkCapped = MkBitcoinAmount . capTo21Mill++-- | Convert to 21 million, zero as floor+capTo21Mill :: Integer -> Word64+capTo21Mill i = fromIntegral $+    max 0 cappedValue+        where+            cappedValue = min i $ fromIntegral (maxBound :: BtcAmount)++instance Serialize BtcAmount where+    put = putWord64le . fromIntegral . toInteger+    get = mkCapped . fromIntegral <$> getWord64le++instance ToJSON BtcAmount where+    toJSON amt = Number $ scientific+        (fromIntegral $ toInteger amt) 0++instance FromJSON BtcAmount where+    parseJSON = withScientific "BtcAmount" $+        fmap (\w -> mkCapped $ fromIntegral (w :: Word64)) . parseJSONWord++
+ src/Bitcoin/Compare.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE DeriveGeneric #-}+module Bitcoin.Compare where++import Bitcoin.SpendCond.Cond+import Bitcoin.Util++import           Data.Word                      (Word32)+import qualified Data.List.NonEmpty             as NE+import qualified Network.Haskoin.Transaction    as HT+import qualified Network.Haskoin.Crypto         as HC+import GHC.Generics       (Generic)+++data DiffInfo = DiffInfo [(HC.Address,ValDiff)]++data ValDiff =+    Increase BtcAmount+  | Decrease BtcAmount+  | NoChange+        deriving (Eq, Show, Generic)++data TxMismatch r =+    TxVersionMismatch Word32 Word32+  | TxLocktimeMismatch (Maybe LockTimeDate) (Maybe LockTimeDate)+  | TxInMismatch (InMismatch r)+  | TxOutMisMatch OutMismatch+        deriving (Eq, Show, Generic)++data InMismatch r =+    InPrevOutMismatch HT.OutPoint HT.OutPoint+  | InRdmScrMismatch r r+  | InSequenceMismatch Word32 Word32+        deriving (Eq, Show, Generic)++data OutMismatch =+    OutAddressMismatch HC.Address HC.Address+        deriving (Eq, Show, Generic)+++-- | Compare two transactions, ignoring output amounts and signature data, and return either+--    a) mismatch error+--    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 oldTx newTx =+       compareProp oldTx newTx btcVer TxVersionMismatch+    >> compareProp oldTx newTx btcLock TxLocktimeMismatch+    >>              getFirstErr TxInMismatch compareIns+    >> DiffInfo <$> getFirstErr TxOutMisMatch compareOuts++  where+    getFirstErr mkErr eL = if not $ null (lefts eL) then Left $ mkErr (head $ lefts eL) else Right (rights eL)+    compareIns = zipWith inputDiff (NE.toList $ btcIns oldTx) (NE.toList $ btcIns newTx)+    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 oldIn newIn =+       compareProp oldIn newIn btcPrevOut   InPrevOutMismatch+    >> compareProp oldIn newIn inputCondScript InRdmScrMismatch+    >> compareProp oldIn newIn btcSequence  InSequenceMismatch+    >> return ()++outputDiff :: BtcOut -> BtcOut -> Either OutMismatch (HC.Address,ValDiff)+outputDiff oldOut newOut =+    compareProp oldOut newOut btcAddress OutAddressMismatch+    >>= \addr -> Right (addr,valDiff)+  where+    newAmount = nonDusty (btcAmount newOut)+    oldAmount = nonDusty (btcAmount oldOut)+    valDiff+        | newAmount == oldAmount = NoChange+        | newAmount > oldAmount  = Increase (newAmount - oldAmount)+        | otherwise              = Decrease (oldAmount - newAmount)++-- 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+  where+    txClearOutVal  tx  = tx { btcOuts = map outputValClear (btcOuts tx) }+    outputValClear out = out { btcAmount = nullAmount }+++-- Util+compareProp :: Eq prop => a -> a -> (a -> prop) -> (prop -> prop -> e) -> Either e prop+compareProp old new getProp mkErr =+    if getProp old == getProp new+        then Right (getProp new)+        else Left $ mkErr (getProp old) (getProp new)+
+ src/Bitcoin/Config.hs view
@@ -0,0 +1,10 @@+module Bitcoin.Config where++import Bitcoin.Amount+++configDustLimit :: BtcAmount+configDustLimit = 6000+++
+ src/Bitcoin/Conversion.hs view
@@ -0,0 +1,73 @@+module Bitcoin.Conversion+(+  module Bitcoin.Conversion+, module Bitcoin.Types+, module Bitcoin.SpendCond.Cond+)+where++import Bitcoin.SpendCond.Cond+import Bitcoin.Types++import qualified Data.List.NonEmpty         as NE+import qualified Data.ByteString            as B+import qualified Data.Serialize             as Bin+import qualified Network.Haskoin.Transaction as HT+import qualified Network.Haskoin.Crypto     as HC+++toTxOut :: ScriptPubKey outType => OutputG outType -> HT.TxOut+toTxOut MkOutputG{..} = HT.TxOut+    (fromIntegral . toInteger $ btcOutAmount)+    (Bin.encode $ asScript $ scriptPubKey btcOutType)++toInRaw :: B.ByteString -> InputG inType sigData -> HT.TxIn+toInRaw inpScr MkInputG{..} = HT.TxIn btcPrevOut inpScr btcSequence++toUnsigTxIn :: InputG inType sigData -> HT.TxIn+toUnsigTxIn = toInRaw B.empty++toSigTxIn :: SignatureScript t sigData => InputG t sigData -> HT.TxIn+toSigTxIn btcIn@MkInputG{..} =+    toInRaw (Bin.encode $ asScript $ inputScript btcSigData btcInType) btcIn+++toTxOut' :: BtcOut -> HT.TxOut+toTxOut' (BtcOut adr val) =+    toTxOutRaw (adr, nonDusty val)++toTxOutRaw :: (HC.Address, BtcAmount) -> HT.TxOut+toTxOutRaw (adr, val) = HT.TxOut+    (fromIntegral . toInteger $ val)+    (addressToScriptPubKeyBS adr)++toChangeTxOut :: BtcAmount -> ChangeOut -> HT.TxOut+toChangeTxOut val ChangeOut{..} =+    toTxOutRaw (btcChangeAddr, val)++getAllOuts :: BtcTx r a -> [HT.TxOut]+getAllOuts BtcTx{..} =+    map toTxOut' finalOuts ++ maybe [] mkChgOut btcChgOut+    where+        -- | Remove zero-value outputs+        finalOuts = filter ((/= nullAmount) . btcAmount) btcOuts+        inVal = sum . NE.toList $ NE.map btcInValue btcIns+        outVal = sum $ map (nonDusty . btcAmount) btcOuts+        mkChgOut co = [ toChangeTxOut (inVal - outVal - btcAbsFee_ co) co ]+++toUnsignedTx :: BtcTx r a -> HT.Tx+toUnsignedTx tx@BtcTx{..} = toTxWithIns+    (NE.map toUnsigTxIn btcIns) tx++toTxWithIns :: NE.NonEmpty HT.TxIn -> BtcTx r a -> 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 tx@BtcTx{..} = toTxWithIns+    (NE.map toSigTxIn btcIns) tx+
+ src/Bitcoin/Dust.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE DeriveAnyClass #-}+module Bitcoin.Dust+(+  NonDusty+, nonDusty+, nullAmount+, PossiblyDusty(..)+)++where++import Bitcoin.Amount+import Bitcoin.Config+import Bitcoin.Util+import Bitcoin.Error+++-- |Connot represent an amount/output/transaction that contains "dust"+data NonDusty a = NonDusty a+    deriving (Eq, Show, Typeable)++class PossiblyDusty a where+    mkNonDusty :: a -> Either BtcError (NonDusty a)++nonDusty :: PossiblyDusty a => NonDusty a -> a+nonDusty (NonDusty a) = a++nullAmount = either (error "BUG") id $ mkNonDusty (0 :: BtcAmount)++instance PossiblyDusty BtcAmount where+    mkNonDusty amt =+        if amt < configDustLimit && amt /= 0+            then Left $ DustOutput configDustLimit+            else Right $ NonDusty amt++instance Ord (NonDusty BtcAmount) where+    compare (NonDusty a1) (NonDusty 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 ToJSON (NonDusty BtcAmount) where+    toJSON (NonDusty a) = toJSON a++instance FromJSON (NonDusty BtcAmount) where+    parseJSON v = parseJSON v >>= \(amt :: BtcAmount) ->+        case mkNonDusty amt of+            Left _  -> fail $ "dusty BtcAmount: " ++ show amt+            Right nda -> return nda+
+ src/Bitcoin/Error.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE DeriveGeneric #-}+module Bitcoin.Error where++import Bitcoin.Amount+import Bitcoin.Util++data BtcError =+    InsufficientFunds   { eAmountMissing    :: BtcAmount }+  | DustOutput          { eDustLimit        :: BtcAmount }+        deriving (Eq, Show, Typeable, Generic)
+ src/Bitcoin/Fee.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Bitcoin.Fee where++-- import Bitcoin.Types+import Bitcoin.Amount+import Bitcoin.Util (calcTxSize)+import qualified Network.Haskoin.Transaction as HT+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).+class HasFee a where+    absoluteFee :: TxByteSize -> a -> BtcAmount++-- |For compatibility+instance HasFee BtcAmount where+    absoluteFee _ = id    -- Same as constant fee++data Constant = Constant BtcAmount+instance HasFee Constant where+    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)+instance HasFee SatoshisPerByte where+    absoluteFee txByteSize (SatoshisPerByte satoshisPerByte) =+        fromIntegral txByteSize * satoshisPerByte++mkRelativeFeeTx+    :: HasFee fee+    => fee                          -- ^Desired (per-byte) transaction fee+    -> (BtcAmount -> HT.Tx)     -- ^Produces desired Bitcoin tx with given fee+    -> HT.Tx+mkRelativeFeeTx fee mkTxFunc =+    mkTxSizeFee pass2Tx+    where+        pass2Tx = mkTxSizeFee pass1Tx+        pass1Tx = mkTxFunc (0 :: BtcAmount)+        mkTxSizeFee tx = mkTxFunc $ absoluteFee (calcTxSize tx) fee+++
+ src/Bitcoin/LockTime/Types.hs view
@@ -0,0 +1,86 @@+module Bitcoin.LockTime.Types+(+  BtcLockTime(..)+, LockTimeDate(..)+, LockTimeBlockHeight(..)+, fromDate+)+where++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+++-- |Data type representing a Bitcoin LockTime, which specifies a point in time.+class BtcLockTime a where+    parseLockTime :: Word32 -> Maybe a+    toWord32      :: a -> Word32++-- |Specifies a point in time using a timestamp with 1-second accuracy (till 2106-02-07)+data LockTimeDate = LockTimeDate Word32+    deriving (Eq, Ord, Typeable)++-- | A value of "n" represents the point in time at which Bitcoin block number "n" appears+data LockTimeBlockHeight = LockTimeBlockHeight Word32+    deriving (Eq, Ord, Typeable)++instance BtcLockTime LockTimeBlockHeight where+    toWord32 (LockTimeBlockHeight w) = w+    parseLockTime tstamp+            | tstamp > 0 && tstamp < 500000000 = Just $ LockTimeBlockHeight tstamp+            | otherwise = Nothing++instance BtcLockTime LockTimeDate where+    toWord32 (LockTimeDate w) = w+    parseLockTime = fromDate . posixSecondsToUTCTime . fromIntegral+++-- | Convert a 'Data.Time.Clock.UTCTime' to a 'LockTimeDate'.+--   Returns 'Nothing' if the date is later than 2106-02-07+--    (or earlier than 1985-11-05).+fromDate :: UTCTime -> Maybe LockTimeDate+fromDate date+    | tstamp <- utcTimeToPOSIXSeconds date+    , tstamp >= 500000000 && round tstamp <= fromIntegral (maxBound :: Word32) =+        Just $ LockTimeDate $ fromIntegral (round tstamp)+    | otherwise = Nothing+++instance ToJSON LockTimeBlockHeight where+    toJSON = encodeJSONLockTime+instance FromJSON LockTimeBlockHeight where+    parseJSON = withScientific "LockTimeBlockHeight" parseJSONLockTime++instance ToJSON LockTimeDate where+    toJSON = encodeJSONLockTime+instance FromJSON LockTimeDate where+    parseJSON = withScientific "LockTimeDate" parseJSONLockTime++parseJSONLockTime :: forall a. BtcLockTime a => Scientific -> Parser a+parseJSONLockTime sci =+    (parseLockTime <$> parseJSONWord sci) >>= maybe (fail "invalid locktime") return++encodeJSONLockTime :: BtcLockTime a => a -> Value+encodeJSONLockTime blt = Number $ scientific (fromIntegral $ toWord32 blt) 0++instance Show LockTimeBlockHeight where+    show (LockTimeBlockHeight blockNum) = "block number " ++ show blockNum++instance Show LockTimeDate where+    show (LockTimeDate i) = show $ posixSecondsToUTCTime (fromIntegral i)++instance Serialize LockTimeBlockHeight where+    put = putWord32le . toWord32+    get = parseBinLockTime++instance Serialize LockTimeDate where+    put = putWord32le . toWord32+    get = parseBinLockTime++parseBinLockTime :: forall a. BtcLockTime a => Get a+parseBinLockTime = getWord32le >>=+    maybe (fail "invalid locktime") return . parseLockTime
+ src/Bitcoin/LockTime/Util.hs view
@@ -0,0 +1,27 @@+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+++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)+
+ src/Bitcoin/Orphans.hs view
@@ -0,0 +1,20 @@+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
+ src/Bitcoin/Signature.hs view
@@ -0,0 +1,132 @@+module Bitcoin.Signature+(+  module Bitcoin.Conversion+, TransformSigData(..)+, signTx, signSettleTx+, verifyTx+)+where++import Bitcoin.Conversion+import Bitcoin.Util++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+++class SpendCondition r => TransformSigData newSd oldSd r where+    mkSigData :: oldSd -> BtcSig -> r -> newSd++++++-- | 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++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++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)+  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++verifyTx :: (SpendFulfillment ss r, SpendCondition r, HasSpendCond r t) =>+                BtcTx t 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)++verifyInput :: forall r t ss.+               (SpendFulfillment ss r, SpendCondition r, HasSpendCond r t) =>+                  BtcTx t ss+               -> Word32+               -> InputG t 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) =+                ( 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+getHashForSig tx rdmScr idx = HS.txSigHash+    (toUnsignedTx tx) (conditionScript rdmScr) (toInt idx)+++txSize :: SignatureScript t ss => BtcTx t 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))+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++
+ src/Bitcoin/SinglePair.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE DeriveGeneric #-}+module Bitcoin.SinglePair+(+  module Bitcoin.SinglePair+, module X+)+where++import Bitcoin.Types            as X+import Bitcoin.LockTime.Util    as X+import Bitcoin.Signature        as X+import Bitcoin.SpendCond.Cond   as X+import Bitcoin.Tx+import qualified Network.Haskoin.Script as HS+import qualified Network.Haskoin.Crypto as HC+import qualified Data.List.NonEmpty     as NE+import Control.Monad.Time+{-# ANN module ("HLint: ignore Use isNothing"::String) #-}+++instance (Show r, Show sd) => IsTxLike SigSinglePair r sd where+    toBtcTx SigSinglePair{..} =+        BtcTx 1 inputL [singleOutput] Nothing Nothing+            where inputL  = singleInput NE.:| []+    fromBtcTx tx@BtcTx{..}+        | btcVer == 1 && btcLock == Nothing = SigSinglePair input output+        | otherwise = error $ "Modified transaction data: " ++ show tx+            where input  = head . NE.toList $ btcIns+                  output = head btcOuts++mkSigSinglePair :: InputG r () -> BtcOut -> SigSinglePair r ()+mkSigSinglePair pin out =+    SigSinglePair (adjustSignFlag pin) out+  where+    adjustSignFlag = setSignFlag $+        if btcAmount out /= nullAmount+            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 ) =>+       HC.PrvKeyC+    -> SigSinglePair t ()+    -> m (Either BtcError (SigSinglePair t BtcSig))+signPair prvKey sp@SigSinglePair{..} =+    fmap fromBtcTx <$> signTx (const $ return prvKey) (toBtcTx sp)++singlePairVerifySig ::+   ( Show ss, Show t+   , SpendFulfillment ss r+   , SpendCondition r+   , HasSpendCond r t+   ) =>+   SigSinglePair t ss -> Either VerifyError ()+singlePairVerifySig sp = verifyTx (toBtcTx sp)++toClientSignedTx :: Show t => NE.NonEmpty (SigSinglePair t BtcSig) -> BtcTx t BtcSig+toClientSignedTx spL = foldr addInOut (toBtcTx $ NE.last spL) (NE.init spL)+    where addInOut SigSinglePair{..} tx@BtcTx{..} =+             tx { btcIns  = singleInput NE.<| btcIns+                , btcOuts = singleOutput : btcOuts+                }+++getSigData :: SigSinglePair t 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++fundingValue :: SigSinglePair t BtcSig -> BtcAmount+fundingValue SigSinglePair{..} = btcInValue singleInput++clientChangeVal :: SigSinglePair t BtcSig -> BtcAmount+clientChangeVal SigSinglePair{..} = nonDusty (btcAmount singleOutput)++clientChangeAddr :: SigSinglePair t BtcSig -> HC.Address+clientChangeAddr SigSinglePair{..} = btcAddress singleOutput++clearSig :: SigSinglePair t BtcSig -> SigSinglePair t ()+clearSig = spMapSigData $ const ()++spMapSigData :: (a -> b) -> SigSinglePair t a -> SigSinglePair t b+spMapSigData f sp@SigSinglePair{..} = sp { singleInput = mapSigData f singleInput }+++-- | 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+
+ src/Bitcoin/SpendCond/Cond.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass, KindSignatures #-}+module Bitcoin.SpendCond.Cond+(+  module Bitcoin.SpendCond.Cond+, module Bitcoin.Types+)+where++import Bitcoin.Util+import Bitcoin.Types+import Network.Haskoin.Script++import qualified Data.Serialize         as Bin+import qualified Data.Aeson.Types       as JSON+import qualified Data.ByteString        as B+++-- ### Input interface+-- #####################+-- | Script that defines a condition to spend+class SpendCondition c where+    -- | The script will, depending on transaction type,+    --    be placed either in output, input or witness of transaction+    conditionScript :: c -> Script++-- | Script that can spend funds sent to 'conditionScript'+class SpendFulfillment f c where+    -- | Script fulfilling 'conditionScript'+    signatureScript :: f -> c -> Script+    -- | Return all pubkeys-and-signature pairs from "f" and "c". Used for signature verification.+    rawSigs         :: f -> c -> [(PubKey, BtcSig)]+++-- ### Output interface+-- ######################+-- | Script we put in the output of a transaction+class ScriptPubKey c where+    scriptPubKey :: c -> TxOutputScript++class SignatureScript c f where+    -- | The script we put inside a transaction input+    inputScript     :: f -> c -> TxInputScript+    -- | The script we put inside a transaction witness+    witnessScript   :: f -> c -> WitnessScript+++-- | Pay to something+data Pay2 a = Pay2 a+    deriving (Eq, Show, Typeable, Generic, JSON.ToJSON, JSON.FromJSON, Bin.Serialize)++-- | Turns something into its SegWit counterpart+data Witness a = Witness a+    deriving (Eq, Show, Typeable, Generic, JSON.ToJSON, JSON.FromJSON, Bin.Serialize)++-- | Hash a 'SpendCondition'+data ScriptHash a = ScriptHash a+    deriving (Eq, Show, Typeable, Generic, JSON.ToJSON, JSON.FromJSON, Bin.Serialize)++-- | Wraps a 'SpendCondition'+data Cond a = Cond a+    deriving (Eq, Show, Typeable, Generic, JSON.ToJSON, JSON.FromJSON, Bin.Serialize)++-- | 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+++class HasSpendCond c ac | ac -> c where+    getCond :: ac -> c++instance HasSpendCond c (Pay2 (Cond c)) where+    getCond = unwrap . unwrap+instance HasSpendCond c (Pay2 (ScriptHash (Cond c))) where+    getCond = unwrap . unwrap . unwrap+instance HasSpendCond c (Pay2 (Witness (Cond c))) where+    getCond = unwrap . unwrap . unwrap+instance HasSpendCond c (Pay2 (ScriptHash (Witness (Cond c)))) where+    getCond = unwrap . unwrap . unwrap . unwrap++inputCondScript :: HasSpendCond r t => InputG t a -> r+inputCondScript MkInputG{..} = getCond btcInType+++-- ## ScriptPubKey+-- #################+instance SpendCondition c => ScriptPubKey (Pay2 (Cond c)) where+    scriptPubKey (Pay2 (Cond c)) = mkScript $+        conditionScript c++instance SpendCondition c => ScriptPubKey (Pay2 (ScriptHash (Cond c))) where+    scriptPubKey (Pay2 (ScriptHash (Cond c))) =+        p2shScriptPubKey (mkScript $ conditionScript c)++instance WitnessProgram wp => ScriptPubKey (Pay2 (Witness wp)) where+    scriptPubKey (Pay2 (Witness 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))+++-- ## SignatureScript+-- ####################++-- Pay to script+instance SpendFulfillment f c => SignatureScript (Pay2 (Cond c)) f where+    inputScript ss (Pay2 (Cond c)) = mkScript $+        signatureScript ss c+    witnessScript _ _ = WitnessScript []++-- P2SH+instance ( SpendCondition c, SpendFulfillment f c)+        => SignatureScript (Pay2 (ScriptHash (Cond c))) f where+    -- For P2SH inputScript, we add a push of the serialized conditionScript+    inputScript ss (Pay2 (ScriptHash (Cond c))) = mkScript $+        signatureScript ss c <> Script [ opPush $ conditionScript c ]+    witnessScript _ _ = WitnessScript []++-- P2WSH/P2WPKH+instance ( WitnessSig f wp+         , WitnessProgram wp+         )+        => SignatureScript (Pay2 (Witness wp)) f where+    inputScript _ _ = TxInputScript []+    witnessScript ss (Pay2 (Witness wp)) = mkWitnessScript wp ss++-- P2WSH/P2WPKH inside P2SH+instance ( WitnessSig f wp+         , WitnessProgram wp+         )+        => SignatureScript (Pay2 (ScriptHash (Witness wp))) f where+    inputScript   _  (Pay2 (ScriptHash (Witness wp))) = TxInputScript+        [ opPush $ asScript $ scriptPubKey (Pay2 (Witness wp)) ]+    witnessScript ss (Pay2 (ScriptHash (Witness wp))) = mkWitnessScript wp ss++-- Util+p2shScriptPubKey :: TxOutputScript -> TxOutputScript+p2shScriptPubKey s = TxOutputScript+    [ OP_HASH160, opPush $ hash160 (asScript s), OP_EQUAL ]++++-- ## P2PKH+-- ##########+data PubkeyHash = PubkeyHash PubKey+    deriving (Eq, Show, Typeable, Generic, JSON.ToJSON, JSON.FromJSON, Bin.Serialize)+data SpendPKH   = SpendPKH   BtcSig+    deriving (Eq, Show, Typeable, Generic, JSON.ToJSON, JSON.FromJSON, Bin.Serialize)++instance SpendCondition PubkeyHash where+    conditionScript (PubkeyHash pk) = Script+        [ OP_DUP, OP_HASH160, opPush $ hash160 pk, OP_EQUALVERIFY, OP_CHECKSIG ]++instance SpendFulfillment SpendPKH PubkeyHash where+    signatureScript (SpendPKH sig) (PubkeyHash pk) = Script [ opPush sig, opPush pk ]+    rawSigs (SpendPKH sig) (PubkeyHash pk) = [(pk, sig)]++instance SignatureScript PubkeyHash SpendPKH 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++-- P2WSH witness program+instance SpendCondition c => WitnessProgram (Cond c) where+    witnessProgram (Cond c) = Bin.encode $ hash256 (conditionScript c)+    redeemScript wp =+            Script [ opPush  $ Script [ OP_0, opPushData $ witnessProgram wp ] ]++-- P2WPKH witness program+instance WitnessProgram PubkeyHash where+    witnessProgram (PubkeyHash pk) = Bin.encode $ hash160 pk+    redeemScript _ = mempty+++class WitnessSig ws wp where+    mkWitnessScript :: wp -> (ws -> WitnessScript)++-- P2SH witness program+instance (SpendCondition c, SpendFulfillment f c) => WitnessSig f (Cond c) where+    -- Same as P2SH inputScript+    mkWitnessScript (Cond c) f = mkScript . asScript $+        inputScript f (Pay2 (ScriptHash (Cond c)))++-- P2WPKH witness program+instance WitnessSig SpendPKH PubkeyHash where+    -- Same as P2PKH inputScript+    mkWitnessScript pkh sig = mkScript . asScript $+        inputScript sig (Pay2 (Cond pkh))+
+ src/Bitcoin/SpendCond/Spec.hs view
@@ -0,0 +1,120 @@+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+                          ]+
+ src/Bitcoin/Tx.hs view
@@ -0,0 +1,17 @@+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)+    return $ all (== True) isLockedLst++++
+ src/Bitcoin/Types.hs view
@@ -0,0 +1,283 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE KindSignatures, DeriveAnyClass, DeriveFunctor #-}+module Bitcoin.Types+(+  module Bitcoin.Types+, 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.ByteString        as B+import qualified Data.Serialize         as Bin+import qualified Data.Aeson.Types       as JSON+import           Data.Word              (Word32)++import qualified Network.Haskoin.Transaction as HT+import qualified Network.Haskoin.Script as HS+import qualified Network.Haskoin.Crypto as HC+++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)+++-- | 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)++-- | Generic output+data OutputG outType =+    MkOutputG+    { btcOutAmount  :: BtcAmount+    , btcOutType    :: outType+    } deriving (Eq, Show, Typeable, Generic, Bin.Serialize, JSON.ToJSON, JSON.FromJSON)++data BtcOut = BtcOut+    { btcAddress    :: HC.Address+    , btcAmount     :: NonDusty BtcAmount+    } deriving (Eq, Show, Typeable, Generic, Bin.Serialize, JSON.ToJSON, JSON.FromJSON)++-- | 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)++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)++data DustPolicy = KeepDust | DropDust+    deriving (Eq, Show, Typeable, Generic, Bin.Serialize, JSON.ToJSON, JSON.FromJSON)++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)++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)++-- 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 }++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++-- | Create inputs from P2SH outputs that pay to the given redeemScript+-- getPrevIn :: SpendCondition r => HT.Tx -> Pay2 (ScriptHash (Cond r)) -> [InputG r ()]+-- getPrevIn tx rdmScr =+--     map mkInput $ catMaybes $+--         zipWith relevantIndexes [0..] (HT.txOut tx)+--   where+--     scrHash = scriptHash160 $ conditionScript rdmScr+--     mkInput (idx,val) = mkNoSigTxIn (mkPrevOut idx) (fromIntegral val) rdmScr+--     mkPrevOut = HT.OutPoint (HT.txHash tx)+--     checkMatch idx (hash,val) = if hash == scrHash then Just (idx,val) else Nothing+--     relevantIndexes idx out =+--         either (const Nothing) (checkMatch idx)+--             (decodeScriptHash (HT.scriptOutput out) >>= \sh -> Right (sh, HT.outValue out))++instance (Bin.Serialize t, Bin.Serialize sd) => Bin.Serialize (BtcTx t sd) where+    put BtcTx{..} =+           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)+
+ src/Bitcoin/Util.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Bitcoin.Util+(+  module Bitcoin.Util+, module PaymentChannel.Internal.Util+)+where++import           PaymentChannel.Internal.Util+import           Data.Word (Word32)+import           Data.String (fromString)++import qualified Data.Serialize             as Bin+import qualified Data.ByteString            as B+import qualified Data.ByteString.Base16     as B16+import qualified Network.Haskoin.Transaction as HT+import qualified Network.Haskoin.Util       as HU+import qualified Network.Haskoin.Script     as HS+import qualified Network.Haskoin.Crypto     as HC+import qualified Network.Haskoin.Node       as HN+import qualified Data.List.NonEmpty         as NE++++instance Monoid HS.Script where+    mempty = HS.Script []+    mappend (HS.Script scr1) (HS.Script scr2) =+        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+        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++hash256 :: Bin.Serialize a => a -> HC.Hash256+hash256 = HC.hash256 . serialize++hash160 :: Bin.Serialize a => a -> HC.Hash160+hash160 = HC.hash160 . HC.getHash256 . HC.hash256 . serialize++opPush :: Bin.Serialize a => a -> HS.ScriptOp+opPush = HS.opPushData . Bin.encode++addressToScript :: HC.Address -> HS.ScriptOutput+addressToScript addr =+    case addr of+        a@(HC.PubKeyAddress _) -> HS.PayPKHash a+        a@(HC.ScriptAddress _) -> HS.PayScriptHash a++decodeScriptHash :: B.ByteString -> Either String HC.Hash160+decodeScriptHash bs =+    HS.decodeOutputBS bs >>=+    \scrOut -> case scrOut of+        HS.PayScriptHash a -> getP2SHAddr a+        x                  -> Left $ "Expected P2SH output, found: " ++ show x+  where+    getP2SHAddr (HC.ScriptAddress h) = Right h+    getP2SHAddr (HC.PubKeyAddress _) = Left "Expected P2SH address, found P2PKH address"++addressToScriptPubKeyBS :: HC.Address -> B.ByteString+addressToScriptPubKeyBS = HS.encodeOutputBS . addressToScript++replaceScriptInput :: Word32 -> HS.Script -> HT.Tx -> HT.Tx+replaceScriptInput index scriptIn tx =+    HT.createTx (HT.txVersion tx) newTxIns (HT.txOut tx) (HT.txLockTime tx)+        where newTxIns = HU.updateIndex (fromIntegral index) (HT.txIn tx) replaceScriptIn+              replaceScriptIn txIn = txIn { HT.scriptInput = Bin.encode scriptIn}++removeOutputs :: HT.Tx -> HT.Tx+removeOutputs tx =+    HT.createTx (HT.txVersion tx) (HT.txIn tx) [] (HT.txLockTime tx)++appendOutput :: HT.Tx -> HT.TxOut -> HT.Tx+appendOutput tx txOut =+    HT.createTx (HT.txVersion tx) (HT.txIn tx) ( oldOuts ++ [txOut] ) (HT.txLockTime tx)+        where oldOuts = HT.txOut tx++bitcoinPayPK :: HC.PubKeyC -> HS.Script+bitcoinPayPK pk = HS.encodeOutput $ HS.PayPKHash $ HC.pubKeyAddr pk+bitcoinPayPKBS = serialize . bitcoinPayPK+    where serialize = Bin.encode++
− src/Data/Bitcoin/PaymentChannel.hs 
@@ -1,285 +0,0 @@-{-|-Module      : Data.Bitcoin.PaymentChannel-Description : Bitcoin payment channel library-Copyright   : (c) Rune K. Svendsen, 2016-License     : PublicDomain-Maintainer  : runesvend@gmail.com-Stability   : experimental-Portability : POSIX--In order to set up a payment channel between a sender and a receiver, the two parties must- first agree on three [1] parameters for the channel:--    (1) sender public key-    (2) receiver public key-    (3) channel expiration date-- These parameters- are contained in 'ChannelParameters', from which the Bitcoin address used to fund- the payment channel can be derived using- 'getFundingAddress'. The transaction which pays to this address is the channel funding- transaction, and information about it is contained in a 'FundingTxInfo'.- So, the channel funding transaction will contain an output which pays to the address returned by- 'getFundingAddress', and once this transaction is created and in- the blockchain, a 'SenderPaymentChannel' and- 'ReceiverPaymentChannel' instance can be created, after first creating the 'FundingTxInfo' instance.- 'FundingTxInfo' contains three pieces of information about the funding transaction:--    (1) hash/transaction ID-    (2) index/vout of the funding output (paying to 'getFundingAddress' address),-    (3) value of the funding output (paying to 'getFundingAddress' address)--With 'ChannelParameters' and 'FundingTxInfo',- the sender can create a new 'SenderPaymentChannel', plus- the first channel payment, using 'channelWithInitialPaymentOf'. 'channelWithInitialPaymentOf'- takes two additional arguments:--    (1) a signing function which, given a hash, produces a signature that verifies against-        'cpSenderPubKey' in 'ChannelParameters'-    (2) the value of the first channel payment-- The sender will want to use @flip 'Network.Haskoin.Crypto.signMsg' senderPrivKey@ as the signing- function, where @senderPrivKey@ is the private key from which 'cpSenderPubKey' is derived.- 'channelWithInitialPaymentOf' will return the first channel 'Payment' as well as- the new 'SenderPaymentChannel' state. The new state is stored, and the 'Payment'- transferred to the receiver.--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 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- to the receiver by the specified amount, and an updated 'Data.Bitcoin.PaymentChannel.Types.SenderPaymentChannel' state.- The receiver will verify and register this 'Payment' on its side using 'recvPayment', which, on success,- returns the value received with this payment plus the updated- 'ReceiverPaymentChannel' state object.--Payments can flow from the sender to receiver until either the channel is exhausted, or getting- close to expiration (see important note below). In either case the receiver will use 'getSettlementBitcoinTx' to create the settlement- Bitcoin transaction, and publish this transaction to the Bitcoin network. The settlement Bitcoin- 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.--[1] In addition to this, two configuration options must also be agreed upon: a "dust limit",- and a "settlement period" (measured in hours), which is subtracted from the channel expiration- date in order to arrive at the effective (earlier) expiration date. This is necessary to give the- server/receiver time to publish the settlement transaction before the refund transaction becomes- valid. The dust limit is the minimum amount that the server is willing to accept- as the client change value in the- payment transaction. It's only relevant if the channel is- emptied of value completely, but it is necessary because the server doesn't want to accept- payments based on transactions it cannot publish via the Bitcoin P2P network, because they- contain an output of minuscule value. Sensible values are contained in 'defaultConfig', but- client/sender and server/receiver need to agree on these parameter as well, although they are- only relevant 1) (in the case of the dust limit) if the channel is compleltely exchausted and- 2) (in case of the "settlemend period") if the client tries to make payments close to expiration- (and, in case the client does, it will just receive an error in response, saying the channel- is now closed).--__/IMPORTANT:/__ /Channel setup is risk free because the sender can derive a refund Bitcoin transaction/- /using 'getRefundBitcoinTx', which returns the bitcoins used to fund the channel back to the sender./- /This refund transaction, however, is not valid until the expiration date specified in 'ChannelParameters',/- /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/- /4 hours before the specified channel expiration time, and possibly earlier, if the receiver wants to/- /be cautious./---}--module Data.Bitcoin.PaymentChannel-(-    -- *Initialization--    -- **Funding-    getFundingAddress,--    -- **State creation-    channelWithInitialPaymentOf,-    channelFromInitialPayment,--    -- *Payment-    sendPayment,-    recvPayment,--    -- *Settlement-    recvPaymentForClose,-    getSettlementBitcoinTx,-    getRefundBitcoinTx-)-where--import Data.Bitcoin.PaymentChannel.Internal.Types-    (PaymentTxConfig(..), Payment(..), FullPayment(..), Config,-     ReceiverPaymentChannelI(..), PaymentChannelState,-    pcsConfig, pcsClientChangeVal, pcsParameters)-import Data.Bitcoin.PaymentChannel.Internal.State-    (newPaymentChannelState, updatePaymentChannelState, isPastLockTimeDate)-import qualified Data.Bitcoin.PaymentChannel.Internal.State as S-import Data.Bitcoin.PaymentChannel.Internal.Payment-    (createPayment, paymentFromState, verifyPaymentSigFromState)-import Data.Bitcoin.PaymentChannel.Internal.Settlement-    (signedSettlementTxFromState)-import Data.Bitcoin.PaymentChannel.Internal.Refund (mkRefundTx)--import Data.Bitcoin.PaymentChannel.Util (getFundingAddress)-import Data.Bitcoin.PaymentChannel.Types--import qualified  Network.Haskoin.Crypto        as HC-import qualified  Network.Haskoin.Transaction   as HT-import            Network.Haskoin.Internals       (toPubKeyG)-import            Data.Time.Clock                 (UTCTime(..))-import            Data.Time.Calendar              (Day(..))----- |Create a new 'SenderPaymentChannel'.--- A 'SenderPaymentChannel' object is created by supplying information about--- the channel and the funding transaction, as well as the value of the first payment.--- Returns a new 'SenderPaymentChannel' state object and the first channel payment.-channelWithInitialPaymentOf ::-       Config                       -- ^ Various configuration options. 'defaultConfig' contains sensible defaults.-    -> ChannelParameters            -- ^ Specifies channel sender and receiver, channel expiration date-    -> FundingTxInfo                -- ^ Holds information about the Bitcoin transaction used to fund the channel-    -> (HC.Hash256 -> HC.Signature) -- ^ Used to sign payments from sender. When given a 'HC.Hash256', produces a signature that verifies against sender pubkey.-    -> HC.Address                   -- ^ Value sender/client change address-    -> BitcoinAmount                -- ^ Value of initial payment. Can be zero.-    -> (BitcoinAmount, FullPayment, SenderPaymentChannel) -- ^Initial payment amount (may be capped), initial payment, and new sender state object-channelWithInitialPaymentOf cfg cp fundInf signFunc sendAddr amount =-    let pConf = CPaymentTxConfig sendAddr-        (CFullPayment (CPayment _ tmpSig) _ _ _) =-            createPayment cp fundInf sendAddr amount signFunc-    in-        flip sendPayment amount $ CSenderPaymentChannel-            (newPaymentChannelState cfg cp fundInf pConf tmpSig) signFunc---- |Create new payment of specified value.-sendPayment ::-    SenderPaymentChannel                -- ^ Sender state object-    -> BitcoinAmount                    -- ^ Amount to send (the actual payment amount is capped)-    -> (BitcoinAmount, FullPayment, SenderPaymentChannel)  -- ^ Actual amount actually sent, payment, and updated sender state object-sendPayment (CSenderPaymentChannel cs signFunc) amountToSend =-    let-        valSent = pcsClientChangeVal cs - newSenderValue-        newSenderValue = max (S.pcsDustLimit cs) (pcsClientChangeVal cs - amountToSend)-        fullPay = paymentFromState cs newSenderValue signFunc-    in-        case updatePaymentChannelState cs fullPay of-            Right newCS ->-                (valSent-                ,fullPay-                ,CSenderPaymentChannel newCS signFunc)-            Left e ->-                error $ "BUG: bad payment" ++ show e---- |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--- 'ChannelParameters'. Receiver beware of Bitcoin network time drift and the--- unpreditable nature of finding new blocks.-getRefundBitcoinTx-    :: HasFee fee-    => SenderPaymentChannel -- ^Sender state object-    -> fee                  -- ^Refund transaction fee-    -> HT.Tx                -- ^Refund Bitcoin transaction-getRefundBitcoinTx (CSenderPaymentChannel cs signFunc) txFee =-    mkRefundTx cs txFee signFunc----- |Create new 'ReceiverPaymentChannel'.--- A channel is initialized with various information--- about the payment channel, as well as the first channel payment--- produced by the sender.-channelFromInitialPayment ::-       UTCTime              -- ^ Current time. Needed for payment verification.-    -> Config               -- ^ Various configuration options. 'defaultConfig' contains sensible defaults.-    -> ChannelParameters    -- ^ Specifies channel sender and receiver, plus channel expiration date-    -> FundingTxInfo        -- ^ Holds information about the Bitcoin transaction used to fund the channel-    -> FullPayment          -- ^ Initial channel payment-    -> Either PayChanError (BitcoinAmount, ReceiverPaymentChannel) -- ^Error or: value_received plus state object-channelFromInitialPayment now cfg cp fundInf fp@(CFullPayment (CPayment _ sig) _ _ sendAddr) =-        let-            pConf = CPaymentTxConfig sendAddr-        in-            flip (recvPayment now) fp $ CReceiverPaymentChannel-                -- Create a new state with the unverified signature; then verify the same signature in 'recvPayment'-                (newPaymentChannelState cfg cp fundInf pConf sig) ()---- |Register, on the receiving side, a payment made by 'sendPayment' on the sending side.--- Returns error if either the signature or payment amount is invalid, and otherwise--- the amount received with this 'Payment' and a new state object.-recvPayment ::-       UTCTime                      -- ^Current time. Needed for payment verification.-    -> ReceiverPaymentChannelI a    -- ^Receiver state object-    -> FullPayment                  -- ^Payment to verify and register-    -> Either PayChanError (BitcoinAmount, ReceiverPaymentChannelI a) -- ^Value received plus new receiver state object-recvPayment currentTime rpc@(CReceiverPaymentChannel oldState _) fp@(CFullPayment paymnt _ _ _)  =-    updatePaymentChannelState oldState fp >>=-    checkExpiration >>=-    verifyPaymentSignature paymnt >>=-    (\newState -> Right (-        S.channelValueLeft oldState - S.channelValueLeft newState-        , rpc { rpcState = newState })-    )-    where checkExpiration s =-            if isPastLockTimeDate currentTime (pcsConfig oldState) (pcsParameters oldState) then-                Left ChannelExpired-            else-                Right s--verifyPaymentSignature ::-    Payment                 -- ^Payment whose signature to verify-    -> PaymentChannelState  -- ^State object-    -> Either PayChanError PaymentChannelState-verifyPaymentSignature paymnt state =-    if verifyPaymentSigFromState state verifySenderPayment paymnt then-        Right state-    else-        Left SigVerifyFailed-    where verifySenderPayment hash pk sig = HC.verifySig hash sig (toPubKeyG $ getPubKey pk)---- |Same as 'recvPayment' but accept only a payment of zero value---  with a new client change address. Used to produce the settlement---  transaction that returns unsent funds to the client.-recvPaymentForClose ::-    ReceiverPaymentChannelI a    -- ^Receiver state object-    -> FullPayment              -- ^Payment to verify and register-    -> Either PayChanError (ReceiverPaymentChannelI a) -- ^ Receiver state object-recvPaymentForClose (CReceiverPaymentChannel state pki) fp =-    recvPayment futureTimeStamp newAddressState fp >>=-        \(amtRecv, newState) -> case amtRecv of-            0 -> Right newState-            _ -> Left ClosingPaymentBadValue-    where newAddressState = CReceiverPaymentChannel-            { rpcState = S.setClientChangeAddress state (fpChangeAddr fp)-            , rpcPubKeyInfo = pki-            }--          -- When receiving a payment of zero value, which only modifies the-          -- client change address, we don't care about verifying that the channel-          -- hasn't expired yet (which it may well have, since the client wants its-          -- 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-    :: HasFee fee-    => ReceiverPaymentChannelI a       -- ^ Receiver state object-    -> HC.Address                   -- ^ Receiver destination address. Funds sent over the channel will be sent to this address, the rest back to the client change address (an argument to 'channelWithInitialPaymentOf').-    -> (HC.Hash256 -> HC.Signature) -- ^ Function which produces a signature which verifies against 'cpReceiverPubKey'-    -> fee                          -- ^ Bitcoin transaction fee-    -> HT.Tx                        -- ^ Settling Bitcoin transaction-getSettlementBitcoinTx (CReceiverPaymentChannel cs _) =-    signedSettlementTxFromState cs--
− src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Amount.hs 
@@ -1,58 +0,0 @@-module Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Amount where--import qualified Data.Serialize     as Ser-import qualified Data.Serialize.Put as SerPut-import qualified Data.Serialize.Get as SerGet-import           Data.Word-import           Data.Ratio----- |Represents a bitcoin amount as number of satoshis.---  1 satoshi = 1e-8 bitcoin. 1e8 satohis = 1 bitcoin.---  Only amounts >= 0 can be represented, and 'fromInteger' caps to a 'Word64'.---  It is thus not possible to eg. construct a negative BitcoinAmount which, when added to---  another BitcoinAmount, subtracts from its value. Adding two large amounts together will---  never overflow, nor will subtraction underflow.-newtype BitcoinAmount = BitcoinAmount Integer-    deriving (Eq, Ord)-instance Show BitcoinAmount where-    show amount = show (toInteger amount) ++ " satoshi"--instance Num BitcoinAmount where-    (BitcoinAmount a1) * (BitcoinAmount a2) = BitcoinAmount (fromIntegral . capTo21Mill $ a1*a2)-    (BitcoinAmount a1) + (BitcoinAmount a2) = BitcoinAmount (fromIntegral . capTo21Mill $ a1+a2)-    (BitcoinAmount a1) - (BitcoinAmount a2) = BitcoinAmount (fromIntegral . capTo21Mill $ a1-a2)-    abs = id    -- Always positive-    signum (BitcoinAmount 0) = BitcoinAmount 0-    signum (BitcoinAmount _) = BitcoinAmount 1-    fromInteger = BitcoinAmount . fromIntegral . capTo21Mill--instance Enum BitcoinAmount where-    toEnum = BitcoinAmount . fromIntegral . capTo21Mill . fromIntegral-    fromEnum (BitcoinAmount amount) = fromIntegral amount--instance Real BitcoinAmount where-    toRational (BitcoinAmount amount) = toRational amount--instance Integral BitcoinAmount where-    toInteger (BitcoinAmount int) = int-    quotRem (BitcoinAmount a1) (BitcoinAmount a2) =-        ( BitcoinAmount (fromIntegral . capTo21Mill $ res1)-        , BitcoinAmount (fromIntegral . capTo21Mill $ res2)-        )-            where (res1,res2) = quotRem a1 a2--instance Bounded BitcoinAmount where-    minBound = BitcoinAmount 0-    maxBound = BitcoinAmount $ round $ (21e6 :: Ratio Integer) * (1e8 :: Ratio Integer)---- | Convert to 21 million, zero as floor-capTo21Mill :: Integer -> Word64-capTo21Mill i = fromIntegral $-    max 0 cappedValue-        where-            cappedValue = min i $ fromIntegral (maxBound :: BitcoinAmount)--instance Ser.Serialize BitcoinAmount where-    put = SerPut.putWord64le . fromIntegral . toInteger-    get = BitcoinAmount . fromIntegral <$> SerGet.getWord64le
− src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Fee.hs 
@@ -1,28 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Fee where--import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Amount-import qualified Data.Serialize     as Bin----- |Objects from which a Bitcoin fee can be calculated,---   given a transaction (yeah you need to create a tx twice).-class HasFee a where-    absoluteFee :: TxByteSize -> a -> BitcoinAmount---- |For compatibility-instance HasFee BitcoinAmount where-    absoluteFee _ = id    -- Same as constant fee--data Constant = Constant BitcoinAmount-instance HasFee Constant where-    absoluteFee _ (Constant amt) = amt--type TxByteSize = Word--- |Specify a fee as satoshis per byte-newtype SatoshisPerByte = SatoshisPerByte BitcoinAmount -- ^Fee in satoshis per byte-    deriving (Eq, Show, Bin.Serialize, Ord, Num, Enum, Real, Integral)-instance HasFee SatoshisPerByte where-    absoluteFee txByteSize (SatoshisPerByte satoshisPerByte) =-        fromIntegral txByteSize * satoshisPerByte-
− src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/LockTime.hs 
@@ -1,48 +0,0 @@-module Data.Bitcoin.PaymentChannel.Internal.Bitcoin.LockTime where--import           Data.Word (Word32)-import qualified Data.Serialize as Bin-import           Data.Serialize.Put (putWord32le)-import           Data.Serialize.Get (getWord32le)-import           Data.Time.Clock-import           Data.Time.Clock.POSIX-import           Data.Typeable-import           Data.Time.Format ()    -- instance Show UTCTime---- |Data type representing a Bitcoin LockTime, which specifies a point in time.---  Derive a 'BitcoinLockTime' from a 'Data.Time.Clock.UTCTime' using 'fromDate'.-data BitcoinLockTime =-    -- |A value of "n" represents the point in time at which Bitcoin block number "n" appears-    LockTimeBlockHeight Word32 |-    -- |Specifies a point in time using a timestamp with 1-second accuracy-    LockTimeDate UTCTime deriving (Eq, Ord, Typeable)--instance Show BitcoinLockTime where-    show (LockTimeBlockHeight blockNum) = "block number " ++ show blockNum-    show (LockTimeDate date) = show date--instance Bin.Serialize BitcoinLockTime where-    put = putWord32le . toWord32-    get = parseBitcoinLocktime <$> getWord32le---- | Convert from Bitcoin format ('Word32')-parseBitcoinLocktime :: Word32 -> BitcoinLockTime-parseBitcoinLocktime i-    | i <   500000000 = LockTimeBlockHeight i-    | i >=  500000000 = LockTimeDate $ posixSecondsToUTCTime (fromIntegral i)-    | otherwise       = error "GHC bug?"---- | Convert to Bitcoin format (uint32 UNIX timestamp)-toWord32 :: BitcoinLockTime -> Word32-toWord32 (LockTimeBlockHeight i) = i-toWord32 (LockTimeDate date) =-    fromIntegral . round . utcTimeToPOSIXSeconds $ date---- | Convert a 'Data.Time.Clock.UTCTime' to a 'BitcoinLockTime'-fromDate :: UTCTime -> BitcoinLockTime-fromDate = LockTimeDate--usesBlockHeight :: BitcoinLockTime -> Bool-usesBlockHeight (LockTimeBlockHeight _) = True-usesBlockHeight _ = False-
− src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Script.hs 
@@ -1,83 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Data.Bitcoin.PaymentChannel.Internal.Bitcoin.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.Crypto as HC-import qualified Data.ByteString as B---valReceiverSigHash = SigAll True---- |Generates OP_CHECKLOCKTIMEVERIFY redeemScript, which can be redeemed in two ways:---  1) by providing a signature from both server and client---  2) after the date specified by lockTime: by providing only a client signature-paymentChannelRedeemScript :: SendPubKey-                           -> RecvPubKey-                           -> BitcoinLockTime-                           -> Script-paymentChannelRedeemScript clientPK serverPK lockTime =-    let-        -- Note: HI.encodeInt encodes values up to and including 2^31-1 as 4 bytes-        --      and values 2^31 through 2^32-1 (upper limit) as 5 bytes.-        encodeScriptInt = convertEmptyPush . opPushData . B.pack .-                          HI.encodeInt . fromIntegral . toWord32-        -- A push of an empty byte string and OP_0 are one and the same,-        --  but haskoin-core deserializes into OP_0.-        convertEmptyPush (OP_PUSHDATA "" OPCODE) = OP_0-        convertEmptyPush whatever = whatever-        serverPubKey    = getPubKey serverPK-        clientPubKey    = getPubKey clientPK-    in Script-             [OP_IF,-                 opPushData $ serialize serverPubKey, OP_CHECKSIGVERIFY,-             OP_ELSE,-                  encodeScriptInt lockTime, op_CHECKLOCKTIMEVERIFY, OP_DROP,-             OP_ENDIF,-             opPushData $ serialize clientPubKey, OP_CHECKSIG]------ |scriptSig fulfilling 'paymentChannelRedeemScript' using two signatures (client+server)-paymentTxScriptSig :: PaymentSignature -> PaymentSignature -> Script --ScriptSig-paymentTxScriptSig clientSig serverSig = Script-    [opPushData $ serialize clientSig, --sig including SigHash byte-    opPushData $ serialize serverSig, --sig including SigHash byte-    OP_1]   -- Signal that we want to provide both PubKeys---- |scriptSig fulfilling 'paymentChannelRedeemScript' using a single signature (client)---  (not valid until specified lockTime)-refundTxScriptSig :: HC.Signature -> Script-refundTxScriptSig clientSig = Script-    [opPushData (B.append (serialize clientSig) hashTypeByte),-    OP_0]   -- Signal that we want to provide only one pubkey/sig pair (sender's),-            -- after it is checked that the lockTime has expired in the script-        where hashTypeByte = serialize (SigAll False)-------Util-------op_CHECKLOCKTIMEVERIFY = OP_NOP2--scriptToP2SHAddress :: Script -> HC.Address-scriptToP2SHAddress = HC.ScriptAddress . HC.hash160 . HC.getHash256 . HC.hash256 . serialize--getP2SHFundingAddress :: ChannelParameters -> HC.Address-getP2SHFundingAddress = scriptToP2SHAddress . getRedeemScript--getRedeemScript :: ChannelParameters -> Script-getRedeemScript (CChannelParameters senderPK recvrPK lockTime) =-    paymentChannelRedeemScript senderPK recvrPK lockTime--getRedeemScriptBS :: ChannelParameters -> B.ByteString-getRedeemScriptBS = serialize . getRedeemScript--getP2SHInputScript :: ChannelParameters -> Script -> Script-getP2SHInputScript cp scriptSig =-    Script $ scriptOps scriptSig ++ redeemScript-        where-             redeemScript = [opPushData $ getRedeemScriptBS cp]-
− src/Data/Bitcoin/PaymentChannel/Internal/Bitcoin/Util.hs 
@@ -1,58 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Util where---import qualified Data.Serialize as Ser-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as C-import qualified Network.Haskoin.Transaction as HT-import qualified Network.Haskoin.Util as HU-import qualified Network.Haskoin.Script as HS-import qualified Network.Haskoin.Crypto as HC-import           Data.Word (Word32)----- | Converts a pay-to-pubkey-hash address string to Script.--- | Eg. \"1PDGytNA7EJ5XrJdTGKv11VAUFxKnsfwke\" into--- | \"Script [OP_DUP, OP_HASH160, OP_PUSHDATA f3a5194fbf4b3556838e0f773b613a876737a2c6,--- | OP_EQUALVERIFY, OP_CHECKSIG]\"-p2PKAddressToScript :: String -> Maybe HS.Script-p2PKAddressToScript addrStr =-    HS.encodeOutput . HS.PayPKHash <$> HC.base58ToAddr (C.pack addrStr)---- | Converts a pay-to-script-hash address string to Script.--- | Eg. \"2PDGytNA7EJ5XrJdTGKv11VAUFxKnsfwke\"-p2SHAddressToScript :: String -> Maybe HS.Script-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--replaceScriptInput :: Word32 -> B.ByteString -> HT.Tx -> HT.Tx-replaceScriptInput index scriptIn tx =-    HT.createTx (HT.txVersion tx) newTxIns (HT.txOut tx) (HT.txLockTime tx)-        where newTxIns = HU.updateIndex (fromIntegral index) (HT.txIn tx) replaceScriptIn-              replaceScriptIn txIn = txIn { HT.scriptInput = scriptIn}--removeOutputs :: HT.Tx -> HT.Tx-removeOutputs tx =-    HT.createTx (HT.txVersion tx) (HT.txIn tx) [] (HT.txLockTime tx)--appendOutput :: HT.Tx -> HT.TxOut -> HT.Tx-appendOutput tx txOut =-    HT.createTx (HT.txVersion tx) (HT.txIn tx) ( oldOuts ++ [txOut] ) (HT.txLockTime tx)-        where oldOuts = HT.txOut tx--bitcoinPayPK :: HC.PubKeyC -> HS.Script-bitcoinPayPK pk = HS.encodeOutput $ HS.PayPKHash $ HC.pubKeyAddr pk-bitcoinPayPKBS = serialize . bitcoinPayPK-    where serialize = Ser.encode
− src/Data/Bitcoin/PaymentChannel/Internal/Crypto/PubKey.hs 
@@ -1,30 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Data.Bitcoin.PaymentChannel.Internal.Crypto.PubKey-(   IsPubKey(..)-,   SendPubKey(..)-,   RecvPubKey(..)-) where--import qualified Network.Haskoin.Crypto as HC-import qualified Data.Serialize     as Bin---- |Types which contain a pubkey-class Bin.Serialize a => IsPubKey a where-    getPubKey :: a -> HC.PubKeyC---- |Wrapper for value sender's public key-newtype SendPubKey = MkSendPubKey {-    getSenderPK    :: HC.PubKeyC-} deriving (Eq, Show, Bin.Serialize)-instance IsPubKey SendPubKey where-    getPubKey = getSenderPK---- |Wrapper for value receiver's public key-newtype RecvPubKey = MkRecvPubKey {-    getReceiverPK  :: HC.PubKeyC-} deriving (Eq, Show, Bin.Serialize)-instance IsPubKey RecvPubKey where-    getPubKey = getReceiverPK--instance IsPubKey HC.XPubKey where-    getPubKey = HC.xPubKey
− src/Data/Bitcoin/PaymentChannel/Internal/Error.hs 
@@ -1,32 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--module Data.Bitcoin.PaymentChannel.Internal.Error where--import Data.Bitcoin.PaymentChannel.Internal.Types-import Data.Bitcoin.PaymentChannel.Internal.Util-import           GHC.Generics--data PayChanError =-     SigVerifyFailed                -- ^Signature verification failed-  |  BadPaymentValue BitcoinAmount  -- ^Payment assigns less value to server than previous payment. Client change value is greater by the specified 'BitcoinAmount'.-  |  OutPointMismatch OutPoint      -- ^'Network.Haskoin.Transaction.OutPoint' in payment does not match the one in server's state-  |  ChangeAddrMismatch Address     -- ^Client change 'Network.Haskoin.Crypto.Address' in payment does not match the one in server's state-  |  RedeemScriptMismatch Script    -- ^redeemScript in payment does not match the one in server's state-  |  DustOutput BitcoinAmount       -- ^Client change value is less than dust limit (payment transaction would contain a dust output)-  |  ClosingPaymentBadValue         -- ^The closing payment only changes the payment transaction change address. Sending value is not allowed.-  |  ChannelExpired                 -- ^Channel has expired or is too close to expiration date-        deriving Generic--instance Show PayChanError where-    show SigVerifyFailed = "Signature verification failed"-    show (BadPaymentValue valDiff) =-        "out-of-order payment (assigns " ++ show valDiff ++ " less value to receiver)"-    show (OutPointMismatch op) = "unexpected outpoint. expected: " ++ show op-    show (ChangeAddrMismatch addr) = "unexpected change address. expected: " ++ show addr-    show (RedeemScriptMismatch scr) = "unexpected redeem script. expected: " ++-        cs (serHex scr)-    show (DustOutput limit) = "server dust limit of " ++ show limit ++-        " not respected by client change output"-    show ClosingPaymentBadValue = "payment not of zero value." ++-        " cannot receive value in closing payment."-    show ChannelExpired = "channel too close to expiration date"
− src/Data/Bitcoin/PaymentChannel/Internal/Payment.hs 
@@ -1,123 +0,0 @@--module Data.Bitcoin.PaymentChannel.Internal.Payment where--import Data.Bitcoin.PaymentChannel.Internal.Types-import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Script-import Data.Bitcoin.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.ByteString as B----- |Represents a P2SH ANYONECANPAY input/output pair from a payment channel.-data UnsignedPayment = UnsignedPayment-  {  fundingOutPoint    :: HT.OutPoint-  ,  outPointValue      :: BitcoinAmount-  ,  redeemScript       :: HS.Script-  ,  changeAddress      :: HC.Address-  ,  changeValue        :: BitcoinAmount-  }---- |Contains ncessary data, except receiver signature, to construct a transaction.-data ClientSignedPayment = ClientSignedPayment-  {  funds      :: UnsignedPayment-  ,  clientSig  :: PaymentSignature-  }--fromState :: PaymentChannelState -> UnsignedPayment-fromState (CPaymentChannelState _ cp (CFundingTxInfo hash idx fundingVal)-          (CPaymentTxConfig changeAddr) _ changeValue _) =-    UnsignedPayment-        (HT.OutPoint hash idx) fundingVal-        (getRedeemScript cp)   changeAddr changeValue--toUnsignedBitcoinTx :: UnsignedPayment -> HT.Tx-toUnsignedBitcoinTx (UnsignedPayment fundingOutPoint _ _ changeAddr changeVal) =-    HT.createTx-        1 --version 1-        -- Redeems payment channel output from blockchain Tx-        [HT.TxIn-            fundingOutPoint-            B.empty-            maxBound]-        [senderOut] -- change output-        0 --lockTime 0-    where senderOut = HT.TxOut-            (fromIntegral . toInteger $ changeVal)-            (addressToScriptPubKeyBS changeAddr)--getHashForSigning :: UnsignedPayment -> HS.SigHash -> HC.Hash256-getHashForSigning up@(UnsignedPayment _ _ redeemScript _ _) =-    HS.txSigHash-        (toUnsignedBitcoinTx up)-        redeemScript-        0 -- In the tx we construct using 'toUnsignedBitcoinTx',-          --  the input in question is always at index 0-----Payment create/verify------ |Create payment, from state. No check of value is performed.-paymentFromState ::-    PaymentChannelState-    -> BitcoinAmount                -- ^ sender change value (subtract 'n' from current sender change value to get payment of value 'n')-    -> (HC.Hash256 -> HC.Signature) -- ^ signing function-    -> FullPayment-paymentFromState (CPaymentChannelState _ cp fti (CPaymentTxConfig changeAddr) _ _ _) =-    createPayment cp fti changeAddr---- |Create payment, pure.-createPayment ::-    ChannelParameters-    -> FundingTxInfo-    -> HC.Address-    -> BitcoinAmount -- ^ sender change value (subtract 'n' from current sender change value to get payment of value 'n')-    -> (HC.Hash256 -> HC.Signature) -- ^ signing function-    -> FullPayment-createPayment cp (CFundingTxInfo hash idx val) changeAddr changeVal signFunc =-    let-        unsignedPayment@(UnsignedPayment op _ script _ _) = UnsignedPayment-                (HT.OutPoint hash idx) val (getRedeemScript cp)-                changeAddr changeVal-        sigHash = if changeVal /= 0 then HS.SigSingle True else HS.SigNone True-        hashToSign = getHashForSigning unsignedPayment sigHash-        sig = signFunc hashToSign-        payment = CPayment changeVal (CPaymentSignature sig sigHash)-    in-        CFullPayment payment op script changeAddr---verifyPaymentSig ::-       ChannelParameters-    -> FundingTxInfo-    -> HC.Address-    -> SendPubKey-    -> (HC.Hash256 -> SendPubKey -> HC.Signature -> Bool)-    -> Payment-    -> Bool-verifyPaymentSig cp (CFundingTxInfo fundTxId idx val) changeAddr sendPK verifyFunc-    (CPayment newSenderVal (CPaymentSignature sig sigHash)) =-        let-            payProxy = UnsignedPayment (HT.OutPoint fundTxId idx) val -                                       (getRedeemScript cp)  changeAddr newSenderVal-            verify = verifyFunc (getHashForSigning payProxy sigHash) sendPK sig-        in-            case sigHash of-                HS.SigSingle True   -> verify-                -- Sender has relinquished remaining channel value-                HS.SigNone   True   -> verify-                _                   -> False---verifyPaymentSigFromState ::-    PaymentChannelState-    -> (HC.Hash256 -> SendPubKey -> HC.Signature -> Bool)-    -> Payment-    -> Bool-verifyPaymentSigFromState (CPaymentChannelState _ cp fti (CPaymentTxConfig changeAddr) _ _ _) =-    verifyPaymentSig cp fti changeAddr (cpSenderPubKey cp)----Payment create/verify-------
− src/Data/Bitcoin/PaymentChannel/Internal/Refund.hs 
@@ -1,62 +0,0 @@-module Data.Bitcoin.PaymentChannel.Internal.Refund where--import Data.Bitcoin.PaymentChannel.Internal.Types-import Data.Bitcoin.PaymentChannel.Internal.State-import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Script-import Data.Bitcoin.PaymentChannel.Internal.Payment-import Data.Bitcoin.PaymentChannel.Internal.Util-import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Fee--import qualified Network.Haskoin.Transaction as HT-import qualified Network.Haskoin.Crypto as HC-import qualified Network.Haskoin.Script as HS---getUnsignedRefundTx :: PaymentChannelState -> BitcoinAmount -> HT.Tx-getUnsignedRefundTx st txFee =-    let-        baseTx = toUnsignedBitcoinTx $ fromState st --create empty payment tx, which redeems funding tx-        refundOut = HT.TxOut-                (fromIntegral . toInteger $ pcsChannelTotalValue st - txFee)-                (pcsClientChangeScriptPubKey st)-        txInput0 = head $ HT.txIn baseTx-    in-        HT.createTx-            (HT.txVersion baseTx)-            -- if the sequence field equals maxBound (0xffffffff)-            -- lockTime features are disabled, so we subtract one-            [ txInput0 { HT.txInSequence = maxBound-1 } ]-            [refundOut]-            -- lockTime of refund tx must be greater than or equal to the lockTime-            -- in the channel redeemScript-            (toWord32 $ pcsLockTime st)---getRefundTxHashForSigning-    :: PaymentChannelState-    -> BitcoinAmount -- ^Bitcoin transaction fee-    -> HC.Hash256-getRefundTxHashForSigning pcs@(CPaymentChannelState _ cp _ _ _ _ _) txFee =-        HS.txSigHash tx (getRedeemScript cp) 0 (HS.SigAll False)-            where tx = getUnsignedRefundTx pcs txFee--refundTxCreate ::-    PaymentChannelState-    -> BitcoinAmount                -- ^Bitcoin tx fee-    -> (HC.Hash256 -> HC.Signature) -- ^Produces a signature that verifies against clientPubKey-    -> HT.Tx-refundTxCreate pcs@(CPaymentChannelState _ cp _ _ _ _ _) txFee signFunc =-        let-            inputScript = getP2SHInputScript cp $ refundTxScriptSig sig-            sig = signFunc $ getRefundTxHashForSigning pcs txFee-        in-            replaceScriptInput 0 (serialize inputScript) $ getUnsignedRefundTx pcs txFee---mkRefundTx :: HasFee fee => PaymentChannelState -> fee -> (HC.Hash256 -> HC.Signature) -> HT.Tx-mkRefundTx pcs txFee signFunc =-    refundTxCreate pcs (absoluteFee (calcTxSize zeroFeeTx) txFee) signFunc-    where-        zeroFeeTx = refundTxCreate pcs (0 :: BitcoinAmount) signFunc--
− src/Data/Bitcoin/PaymentChannel/Internal/Serialization.hs 
@@ -1,174 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, TypeSynonymInstances, FlexibleInstances #-}--module Data.Bitcoin.PaymentChannel.Internal.Serialization where--import           Data.Bitcoin.PaymentChannel.Internal.Types-import           Data.Bitcoin.PaymentChannel.Internal.Util-import           Data.Bitcoin.PaymentChannel.Internal.Error-import qualified Network.Haskoin.Transaction as HT-import           Data.Aeson-import           Data.Aeson.Types (Parser, Pair)-import           Data.Scientific (Scientific, scientific, toBoundedInteger)-import qualified Data.Serialize     as Bin-import qualified Data.Serialize.Put as BinPut-import qualified Data.Serialize.Get as BinGet--import qualified Data.ByteString as B-import           Data.Word (Word64)-import qualified Data.Tagged as Tag---- Generic PayChanError instance-instance Bin.Serialize PayChanError----- JSON-deriving instance ToJSON SendPubKey-deriving instance FromJSON SendPubKey-deriving instance ToJSON RecvPubKey-deriving instance FromJSON RecvPubKey--instance ToJSON BitcoinLockTime where-    toJSON blt = Number $ scientific-        (fromIntegral $ toWord32 blt) 0--instance FromJSON BitcoinLockTime where-    parseJSON = withScientific "BitcoinLockTime" $-        fmap (parseBitcoinLocktime . fromIntegral) . parseJSONInt--instance ToJSON Payment where-    toJSON = object . toJSONObject--toJSONObject :: Payment -> [Pair]-toJSONObject (CPayment changeVal (CPaymentSignature sig flag)) =-    [   "change_value"      .= changeVal-    ,   "signature_data"    .= String (serHex sig)-    ,   "sighash_flag"      .= String (serHex flag)-    ]--parseJSONObject :: Object -> Parser Payment-parseJSONObject o = CPayment-       <$>      o .: "change_value"-       <*>     (CPaymentSignature <$>-                   (o .: "signature_data" >>= withText "SigDataHex" deserHex) <*>-                   (o .: "sighash_flag"   >>= withText "SigHashFlagHex" deserHex))--instance ToJSON FullPayment where-    toJSON CFullPayment {-        fpPayment       = payment,-        fpOutPoint      = (HT.OutPoint txid vout), fpRedeemScript = script,-        fpChangeAddr    = addr } =-            object $-                toJSONObject payment ++-                [   "funding_txid"     .= txid-                ,   "funding_vout"     .= vout-                ,   "redeem_script"    .= String (serHex script)-                ,   "change_address"   .= addr-                ]--instance FromJSON FullPayment where-    parseJSON = withObject "FullPayment" parseFullPayment--parseFullPayment :: Object -> Parser FullPayment-parseFullPayment o = CFullPayment-    <$>     parseJSONObject o-    <*>     (HT.OutPoint <$>-                 o .: "funding_txid" <*>-                 o .: "funding_vout")-    <*>     (o .: "redeem_script" >>= withText "RedeemScriptHex" deserHex)-    <*>      o .: "change_address"--instance ToJSON BitcoinAmount where-    toJSON amt = Number $ scientific-        (fromIntegral $ toInteger amt) 0--instance FromJSON BitcoinAmount where-    parseJSON = withScientific "BitcoinAmount" $-        fmap fromIntegral . parseJSONInt------ Binary-instance Bin.Serialize ChanScript where-    put (ChanScript s) =-        BinPut.putWord16be scriptBSLen >>-        BinPut.putByteString scriptBS-            where scriptBS    = Bin.encode s-                  scriptBSLen = fromIntegral $ B.length scriptBS-    get = either error ChanScript . Bin.decode <$>-            (BinGet.getWord16be >>=-             BinGet.getByteString . fromIntegral)--instance Bin.Serialize PaymentChannelState where-    put (CPaymentChannelState cfg par fti payConf payCount valLeft sig) =-        Bin.put cfg >> Bin.put par >> Bin.put fti >> Bin.put payConf >> Bin.put payCount >>-        Bin.put valLeft >> Bin.put sig-    get = CPaymentChannelState <$> Bin.get <*> Bin.get <*>-        Bin.get <*> Bin.get <*> Bin.get <*> Bin.get <*> Bin.get--instance Bin.Serialize 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.Serialize 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.Serialize PaymentTxConfig where-    put (CPaymentTxConfig sendAddr) =-        Bin.put sendAddr-    get = CPaymentTxConfig <$> Bin.get--instance Bin.Serialize Config where-    put (Config dl sp) =-        Bin.put dl >> Bin.put (Tag.unTagged sp)-    get = Config <$> Bin.get <*> fmap Tag.Tagged Bin.get--instance Bin.Serialize Payment where-    put (CPayment val sig) =-        Bin.put val >> Bin.put sig-    get = CPayment <$> Bin.get <*> Bin.get--instance Bin.Serialize FullPayment where-    put (CFullPayment p op script addr) =-        Bin.put p >> Bin.put op >> Bin.put (ChanScript script) >> Bin.put addr-    get = CFullPayment <$> Bin.get <*> Bin.get <*> fmap getScript Bin.get <*> Bin.get--instance Bin.Serialize PaymentSignature where-    put (CPaymentSignature sig sigHash) =-        Bin.put sig >> Bin.put sigHash-    get = CPaymentSignature <$> Bin.get <*> Bin.get----- Misc.-instance Show Payment where-    show (CPayment val sig) =-        "<Payment: valLeft=" ++ show val ++-        ", sig=" ++ toHexString (Bin.encode sig) ++ ">"--instance Show FullPayment where-    show (CFullPayment p op script addr) =-        "<FullPayment: payment = " ++ show p ++ " " ++-        show (op, script, addr) ++ ">"--parseJSONInt :: Scientific -> Parser Integer-parseJSONInt s =-    case toBoundedInteger s of-        Just (BitcoinAmount i) -> return i-        Nothing -> fail $ "failed to decode JSON number to integer. data: " ++ show s--parseJSONWord :: Scientific -> Parser Word64-parseJSONWord s =-    case toBoundedInteger s of-        Just w -> return w-        Nothing -> fail $ "failed to decode JSON number to Word64. data: " ++ show s---instance Bin.Serialize ReceiverPaymentChannel where-    put (CReceiverPaymentChannel rpc _ ) =-        Bin.put rpc >> Bin.putWord8 0x01-    get = CReceiverPaymentChannel <$> Bin.get <*> return ()--instance Bin.Serialize ReceiverPaymentChannelX where-    put (CReceiverPaymentChannel rpc pki ) =-        Bin.put rpc >> Bin.putWord8 0x02 >> Bin.put pki-    get = CReceiverPaymentChannel <$> Bin.get <*> Bin.get
− src/Data/Bitcoin/PaymentChannel/Internal/Settlement.hs 
@@ -1,90 +0,0 @@-module Data.Bitcoin.PaymentChannel.Internal.Settlement-(-    createSignedSettlementTx-,   signedSettlementTxFromState-)-where--import Data.Bitcoin.PaymentChannel.Internal.Types-import Data.Bitcoin.PaymentChannel.Internal.Payment-import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Script-import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Util-import Data.Bitcoin.PaymentChannel.Internal.Util-import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Fee--import qualified  Network.Haskoin.Transaction as HT-import qualified  Network.Haskoin.Crypto as HC-import qualified  Network.Haskoin.Script as HS---- |Sign everything, and do not allow additional inputs to be added afterwards.-serverSigHash = HS.SigAll False--toUnsignedSettlementTx :: ClientSignedPayment -> HC.Address -> BitcoinAmount -> HT.Tx-toUnsignedSettlementTx-        (ClientSignedPayment-            unsignedPayment@(UnsignedPayment _ valueAvailable _ _ senderVal)-        (CPaymentSignature _ sigHash) ) recvAddr txFee =-    let-        baseTx = toUnsignedBitcoinTx unsignedPayment-        adjustedTx = if sigHash == HS.SigNone True then removeOutputs baseTx else baseTx-        -- TODO: check dust?-        receiverAmount = valueAvailable - senderVal - txFee-        recvOut = HT.TxOut-                (fromIntegral . toInteger $ receiverAmount)-                (addressToScriptPubKeyBS recvAddr)-    in-        appendOutput adjustedTx recvOut--getSettlementTxHashForSigning-    :: ClientSignedPayment-    -> ChannelParameters-    -> HC.Address    -- ^Receiver destination address-    -> BitcoinAmount           -- ^Bitcoin transaction fee-    -> HC.Hash256-getSettlementTxHashForSigning csPayment cp recvAddr txFee =-    HS.txSigHash tx (getRedeemScript cp) 0 serverSigHash-        where tx = toUnsignedSettlementTx csPayment recvAddr txFee--getSignedSettlementTx-    :: ClientSignedPayment-    -> ChannelParameters-    -> HC.Address       -- ^Receiver/server funds destination address-    -> (HC.Hash256 -> HC.Signature) -- ^ Server/receiver's signing function. Produces a signature which verifies against 'cpReceiverPubKey'-    -> BitcoinAmount    -- ^Bitcoin tx fee-    -> HT.Tx-getSignedSettlementTx csPayment@(ClientSignedPayment _ clientSig)-                      cp recvAddr signFunc txFee =-        let-            rawServerSig = signFunc $ getSettlementTxHashForSigning csPayment cp recvAddr txFee-            unsignedTx = toUnsignedSettlementTx csPayment recvAddr txFee-            serverSig = CPaymentSignature rawServerSig serverSigHash-            inputScript = getP2SHInputScript cp $ paymentTxScriptSig clientSig serverSig-        in-            replaceScriptInput 0 (serialize inputScript) unsignedTx--createSignedSettlementTx-    :: HasFee fee-    => ClientSignedPayment-    -> ChannelParameters-    -> HC.Address                   -- ^Receiver/server funds destination address-    -> (HC.Hash256 -> HC.Signature) -- ^Server/receiver's signing function. Produces a signature which verifies against 'cpReceiverPubKey'-    -> fee                          -- ^Bitcoin tx fee-    -> HT.Tx-createSignedSettlementTx csp cp addr signFunc fee =-    getSignedSettlementTx csp cp addr signFunc (absoluteFee (calcTxSize zeroFeeTx) fee)-    where-        zeroFeeTx = getSignedSettlementTx csp cp addr signFunc (0 :: BitcoinAmount)--signedSettlementTxFromState-    :: HasFee fee-    => PaymentChannelState-    -> HC.Address                   -- ^Receiver/server funds destination address-    -> (HC.Hash256 -> HC.Signature) -- ^ Server/receiver's signing function. Produces a signature which verifies against 'cpReceiverPubKey'-    -> fee                          -- ^Bitcoin tx fee-    -> HT.Tx-signedSettlementTxFromState cs@(CPaymentChannelState _ cp _ _ _ _ _) =-    createSignedSettlementTx (cPaymentFromState cs) cp--cPaymentFromState :: PaymentChannelState -> ClientSignedPayment-cPaymentFromState cs@(CPaymentChannelState _ _ _ _ _ _ clientSig) =-    ClientSignedPayment (fromState cs) clientSig
− src/Data/Bitcoin/PaymentChannel/Internal/State.hs 
@@ -1,119 +0,0 @@--- {-# OPTIONS_GHC -fwarn-incomplete-patterns -Werror #-}--module Data.Bitcoin.PaymentChannel.Internal.State where--import Data.Bitcoin.PaymentChannel.Internal.Types-import Data.Bitcoin.PaymentChannel.Internal.Error-import Data.Bitcoin.PaymentChannel.Internal.Util  (addressToScriptPubKeyBS)-import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Script--import qualified Network.Haskoin.Transaction as HT-import qualified Network.Haskoin.Crypto as HC-import qualified Network.Haskoin.Script as HS-import           Data.Time.Clock---pcsChannelTotalValue = ftiOutValue . pcsFundingTxInfo-pcsValueTransferred cs = pcsChannelTotalValue cs - pcsClientChangeVal cs-pcsChannelValueLeft = pcsClientChangeVal-pcsClientPubKey = cpSenderPubKey . pcsParameters-pcsServerPubKey = cpReceiverPubKey . pcsParameters-pcsDustLimit = cDustLimit . pcsConfig-pcsExpirationDate = cpLockTime . pcsParameters-pcsClientChangeAddress = ptcSenderChangeAddress . pcsPaymentConfig-pcsClientChangeScriptPubKey = addressToScriptPubKeyBS . pcsClientChangeAddress-pcsLockTime = cpLockTime . pcsParameters-pcsPrevOut (CPaymentChannelState _ _ (CFundingTxInfo h i _) _ _ _ _) = OutPoint h i--pcsChannelFundingSource :: PaymentChannelState -> HT.OutPoint-pcsChannelFundingSource pcs = HT.OutPoint (ftiHash fti) (ftiOutIndex fti)-    where fti = pcsFundingTxInfo pcs--pcsGetPayment :: PaymentChannelState -> Payment-pcsGetPayment (CPaymentChannelState _ _ _ _ _ val sig) = CPayment val sig---- |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 -> BitcoinAmount-channelValueLeft pcs@(CPaymentChannelState (Config dustLimit _) _ _ _ _ _ _)   =-    pcsClientChangeVal pcs - dustLimit---- |Returns 'True' if all available channel value has been transferred, 'False' otherwise-channelIsExhausted  :: PaymentChannelState -> Bool-channelIsExhausted pcs =-    psSigHash (pcsPaymentSignature pcs) == HS.SigNone True ||-        channelValueLeft pcs == 0--newPaymentChannelState cfg channelParameters fundingTxInfo paymentConfig paySig =-    CPaymentChannelState {-        pcsConfig               = cfg,-        pcsParameters           = channelParameters,-        pcsFundingTxInfo        = fundingTxInfo,-        pcsPaymentConfig        = paymentConfig,-        pcsPaymentCount         = 0,-        pcsClientChangeVal      = ftiOutValue fundingTxInfo,-        pcsPaymentSignature     = paySig-    }----- |Update state with verified payment.-updatePaymentChannelState  ::-    PaymentChannelState-    -> FullPayment-    -> Either PayChanError PaymentChannelState-updatePaymentChannelState (CPaymentChannelState cfg cp fun@(CFundingTxInfo h i _)-                          pconf@(CPaymentTxConfig addr) payCount oldSenderVal _)-    (CFullPayment payment@(CPayment newSenderVal _) payOP payScript payChgAddr)-        | (HT.outPointHash payOP /= h) || (HT.outPointIndex payOP /= i) =-            Left $ OutPointMismatch $ OutPoint h i-        | payChgAddr /= addr =-            Left $ ChangeAddrMismatch addr-        | payScript /= getRedeemScript cp =-            Left $ RedeemScriptMismatch $ getRedeemScript cp-        | newSenderVal > oldSenderVal =-            Left $ BadPaymentValue (newSenderVal - oldSenderVal)-        | otherwise =-            CPaymentChannelState cfg cp fun pconf (payCount+1) newSenderVal . cpSignature <$>-                checkDustLimit cfg payment---- |Create a 'ReceiverPaymentChannelX', which has an associated XPubKey, from a---  'ReceiverPaymentChannel'-mkExtendedKeyRPC :: ReceiverPaymentChannel -> HC.XPubKey -> Maybe ReceiverPaymentChannelX-mkExtendedKeyRPC (CReceiverPaymentChannel pcs _) xpk =-    if xPubKey xpk == getPubKey (pcsServerPubKey pcs) then-            Just $ CReceiverPaymentChannel pcs xpk-        else-            Nothing--checkDustLimit :: Config -> Payment -> Either PayChanError Payment-checkDustLimit (Config dustLimit _) payment@(CPayment senderChangeVal _)-    | senderChangeVal < dustLimit =-        Left $ DustOutput dustLimit-    | otherwise = Right payment--isPastLockTimeDate :: UTCTime-                   -> Config-                   -> ChannelParameters-                   -> Bool-isPastLockTimeDate currentTime (Config _ settlePeriodHrs) (CChannelParameters _ _ (LockTimeDate expTime)) =-    currentTime > (settlePeriod `addUTCTime` expTime)-        where settlePeriod = -1 * fromIntegral (toSeconds settlePeriodHrs) :: NominalDiffTime-isPastLockTimeDate _ _ (CChannelParameters _ _ (LockTimeBlockHeight _)) =-    True-    -- We don't have the current Bitcoin block so we regard the channel as expired,-    -- in order to make we don't accept block count-based locktimes for now.-
− src/Data/Bitcoin/PaymentChannel/Internal/Types.hs 
@@ -1,144 +0,0 @@-{-# LANGUAGE DeriveGeneric, DataKinds #-}-{-# LANGUAGE GeneralizedNewtypeDeriving, TypeSynonymInstances, FlexibleInstances #-}-module Data.Bitcoin.PaymentChannel.Internal.Types-(-    module Data.Bitcoin.PaymentChannel.Internal.Types-  , module Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Amount-  , module Data.Bitcoin.PaymentChannel.Internal.Bitcoin.LockTime-  , module Data.Bitcoin.PaymentChannel.Internal.Crypto.PubKey-  , module Network.Haskoin.Transaction-  , module Network.Haskoin.Crypto-  , module Network.Haskoin.Script-) where--import Data.Bitcoin.PaymentChannel.Internal.Util-import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Amount-import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.LockTime-import Data.Bitcoin.PaymentChannel.Internal.Crypto.PubKey--import           Network.Haskoin.Transaction-import           Network.Haskoin.Crypto-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           Data.Typeable-import           Data.Word-import qualified Data.Tagged as Tag----- |Shared state object used by both value sender and value receiver.-data PaymentChannelState = CPaymentChannelState {-    -- |Holds various optional configuration options-    pcsConfig               ::  Config,-    -- |Defined by the sender and receiver-    pcsParameters           ::  ChannelParameters,-    -- |Retrieved by looking at the in-blockchain funding transaction-    pcsFundingTxInfo        ::  FundingTxInfo,-    pcsPaymentConfig        ::  PaymentTxConfig,-    pcsPaymentCount         ::  Word64,-    -- |Client change value-    pcsClientChangeVal      ::  BitcoinAmount,-    -- |Signature over payment transaction of value 'pcsValueLeft'-    pcsPaymentSignature     ::  PaymentSignature-} deriving (Eq, Show, Typeable)---- |Defines channel: sender, receiver, and expiration date-data ChannelParameters = CChannelParameters {-    cpSenderPubKey      ::  SendPubKey,-    cpReceiverPubKey    ::  RecvPubKey,-    -- |Channel expiration date/time-    cpLockTime          ::  BitcoinLockTime-} deriving (Eq, Show, Typeable)---- |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     ::  BitcoinAmount   -- ^ Value of funding output (channel max value).-} deriving (Eq, Show, Typeable)---- |Holds information about how to construct the payment transaction-data PaymentTxConfig = CPaymentTxConfig {-    -- |Value sender change address-    ptcSenderChangeAddress  ::  HC.Address-} deriving (Eq, Show, Typeable)---- |Miscellaneous configuration options-data Config = Config {-    -- | Refuse to accept/produce payments with a client change value less than this amount.-    cDustLimit          :: BitcoinAmount-    -- | This many hours before the channel expiration date, consider the channel closed.-    --  This gives the receiver time to publish the settlement transaction, before the-    --  refund transaction becomes valid.-  , cSettlementPeriod   :: Hour-} deriving (Eq, Show, Typeable)---- |Contains the bare minimum of information to transfer value from sender to receiver.-data Payment = CPayment {-    -- |Channel value remaining ('pcsValueLeft' of the state from which this payment was made)-    cpClientChange :: BitcoinAmount-    -- |Get payment signature from payment-  , cpSignature    :: PaymentSignature-} deriving (Eq, Typeable)---- |Contains all information required to construct the payment transaction-data FullPayment = CFullPayment {-    fpPayment      :: Payment-    -- |The payment transaction redeems this outpoint-  , fpOutPoint     :: HT.OutPoint-    -- |Using this redeemScript-  , fpRedeemScript :: HS.Script-    -- |Paying this amount to the client/sender change output-  , fpChangeAddr   :: HC.Address-} deriving (Eq, Typeable)---- |Contains payment signature plus sig hash flag byte-data PaymentSignature = CPaymentSignature {-    psSig       ::  HC.Signature-    -- |SigHash flag. Always "SigSingle True".-    ,psSigHash  ::  HS.SigHash-} deriving (Eq, Show, Typeable)---- |Wraps a Network.Haskoin.Script.Script-newtype ChanScript = ChanScript { getScript :: HS.Script } deriving (Eq, Show)--type PayChanState  = PaymentChannelState-type ChanParams = ChannelParameters---- |ReceiverPaymentChannel without public key metadata-type ReceiverPaymentChannel = ReceiverPaymentChannelI ()--- |ReceiverPaymentChannel with BIP32 , "extended" public key metadata-type ReceiverPaymentChannelX = ReceiverPaymentChannelI HC.XPubKey---- |State object for the value receiver. pkInfo holds optional, extra---  data associated with the receiver public key-data ReceiverPaymentChannelI pkInfo = CReceiverPaymentChannel {-    -- |Internal state object-    rpcState        :: PaymentChannelState-  , rpcPubKeyInfo   :: pkInfo-} deriving (Eq, Typeable)---instance Show ReceiverPaymentChannel where-    show (CReceiverPaymentChannel s _) =-        "<ReceiverPaymentChannel:\n\t" ++ show s ++ ">"--instance Show ReceiverPaymentChannelX where-    show (CReceiverPaymentChannel s _) =-        "<ReceiverPaymentChannelX:\n\t" ++ show s ++ ">"---rpcGetXPub = rpcPubKeyInfo--type Hour = Tag.Tagged "Hour" Word32-toSeconds :: Hour -> Integer-toSeconds = fromIntegral . (* 3600) . Tag.unTagged----- Defaults-defaultConfig = Config defaultDustLimit defaultSettlementPeriod--defaultDustLimit = 700 :: BitcoinAmount-defaultSettlementPeriod = 10 :: Hour
− src/Data/Bitcoin/PaymentChannel/Internal/Util.hs 
@@ -1,82 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module Data.Bitcoin.PaymentChannel.Internal.Util-(-    module Data.Bitcoin.PaymentChannel.Internal.Util-,   module Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Util-,   module Data.Bitcoin.PaymentChannel.Internal.Bitcoin.LockTime-,   cs-)-    where--import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Util-import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.LockTime--import Data.String (fromString)--import qualified Data.Serialize as Bin-import qualified Data.Serialize.Get as BinGet--import           Data.Typeable-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 qualified Network.Haskoin.Crypto as HC-import qualified  Network.Haskoin.Transaction as HT-import           Data.String.Conversions (cs)-import           Data.Text.Encoding       (decodeUtf8, encodeUtf8)---calcTxSize :: HT.Tx -> Word-calcTxSize = fromIntegral . B.length . Bin.encode--mapLeft f  = either (Left . f) Right-mapRight f = either Left (Right . f)--dummyHash256 = fromString "3d96c573baf8f782e5f5f33dc8ce3c5bae654cbc888e9a3bbb8185a75febfd76" :: HC.Hash256--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
− src/Data/Bitcoin/PaymentChannel/Test.hs 
@@ -1,113 +0,0 @@-module Data.Bitcoin.PaymentChannel.Test-(-    module Data.Bitcoin.PaymentChannel.Test-  , module Data.Bitcoin.PaymentChannel-  , module Data.Bitcoin.PaymentChannel.Types-  , module Data.Bitcoin.PaymentChannel.Internal.Types-  , module Data.Bitcoin.PaymentChannel.Internal.State-)--where--import           Data.Bitcoin.PaymentChannel-import           Data.Bitcoin.PaymentChannel.Types-import           Data.Bitcoin.PaymentChannel.Internal.Types-import           Data.Bitcoin.PaymentChannel.Util-import           Data.Bitcoin.PaymentChannel.Internal.State hiding (channelIsExhausted, channelValueLeft)-import            Network.Haskoin.Internals       (toPrvKeyG)-import qualified Network.Haskoin.Crypto as HC-import           Network.Haskoin.Test-import           Data.Time.Clock                 (UTCTime(..))-import           Data.Time.Calendar              (Day(..))--import Test.QuickCheck----- TODO: We don't bother testing expiration time for now-nowishTimestamp :: UTCTime-nowishTimestamp = UTCTime (ModifiedJulianDay 57683) 0     -- 2016-10-22--mIN_CHANNEL_SIZE :: BitcoinAmount-mIN_CHANNEL_SIZE = cDustLimit defaultConfig * 2---data ArbChannelPair = ArbChannelPair-    SenderPaymentChannel ReceiverPaymentChannel [BitcoinAmount] [BitcoinAmount] (HC.Hash256 -> HC.Signature)--instance Show ArbChannelPair where-    show (ArbChannelPair spc rpc _ _ _) =-        "SendState: " ++ show spc ++ "\n" ++-        "RecvState: " ++ show rpc--doPayment :: ArbChannelPair -> BitcoinAmount -> ArbChannelPair-doPayment (ArbChannelPair spc rpc sendList recvList f) amount =-    let-        (amountSent, pmn, newSpc) = sendPayment spc amount-        eitherRpc = recvPayment nowishTimestamp rpc pmn-    in-        case eitherRpc of-            Left e -> error (show e)-            Right (recvAmount, newRpc) ->-                ArbChannelPair newSpc newRpc-                    (amountSent : sendList)-                    (recvAmount : recvList)-                    f--instance Arbitrary ArbChannelPair where-    arbitrary = fmap fst mkChanPair--instance Arbitrary PaymentChannelState where-    arbitrary = fmap getPCS mkChanPair-        where getPCS (ArbChannelPair _ rpc _ _ _ , _) = rpcState rpc--instance Arbitrary ChanScript where-    arbitrary = ChanScript . getRedeemScript <$> arbitrary--instance Arbitrary FullPayment where-    arbitrary = fmap snd mkChanPair--instance Arbitrary ChannelParameters where-    arbitrary = fmap fst mkChanParams--instance Arbitrary FundingTxInfo where-    arbitrary = do-        ArbitraryTxHash h <- arbitrary-        i <- arbitrary-        amt <- fmap fromIntegral-            (choose (fromIntegral mIN_CHANNEL_SIZE, round $ 21e6 * 1e8 :: Integer))-            :: Gen BitcoinAmount-        return $ CFundingTxInfo h i amt--instance Arbitrary BitcoinAmount where-    arbitrary = fromIntegral <$> choose (0, round $ 21e6 * 1e8 :: Integer)---mkChanParams :: Gen (ChannelParameters, (HC.PrvKeyC, HC.PrvKeyC))-mkChanParams = do-    -- sender key pair-    ArbitraryPubKeyC sendPriv sendPK <- arbitrary-    -- receiver key pair-    ArbitraryPubKeyC recvPriv recvPK <- arbitrary-    -- TODO: We use an expiration date far off into the future for now-    let lockTime = parseBitcoinLocktime 2524651200-    return (CChannelParameters-                (MkSendPubKey sendPK) (MkRecvPubKey recvPK) lockTime,-           (sendPriv, recvPriv))--mkChanPair :: Gen (ArbChannelPair, FullPayment)-mkChanPair = do-        (cp, (sendPriv, recvPriv)) <- mkChanParams-        fti <- arbitrary-        -- value of first payment-        initPayAmount <- arbitrary-        -- create states-        let (initPayActualAmount,paymnt,sendChan) = channelWithInitialPaymentOf defaultConfig-                cp fti (`HC.signMsg` toPrvKeyG sendPriv) (getFundingAddress cp) initPayAmount-        let eitherRecvChan = channelFromInitialPayment nowishTimestamp defaultConfig cp fti paymnt-        case eitherRecvChan of-            Left e -> error (show e)-            Right (initRecvAmount,recvChan) -> return-                    (ArbChannelPair-                        sendChan recvChan [initPayActualAmount] [initRecvAmount]-                        (`HC.signMsg` toPrvKeyG recvPriv),-                    paymnt)
− src/Data/Bitcoin/PaymentChannel/Types.hs 
@@ -1,132 +0,0 @@-{-|-Module      : Data.Bitcoin.PaymentChannel.Types-Copyright   : (c) Rune K. Svendsen, 2016-License     : PublicDomain-Maintainer  : runesvend@gmail.com--Types used with the interface provided by "Data.Bitcoin.PaymentChannel".---}--{-# LANGUAGE GeneralizedNewtypeDeriving, TypeSynonymInstances, FlexibleInstances #-}--module Data.Bitcoin.PaymentChannel.Types-(-    -- *Interface-    PaymentChannel(..), PayChan,--    -- *State-    SenderPaymentChannel(..), SendPayChan,-    ReceiverPaymentChannel, ReceiverPaymentChannelI, RecvPayChan,-    ReceiverPaymentChannelX, RecvPayChanX,--    -- *Config-    Config(..),defaultConfig,-    FundingTxInfo(..),-    ChannelParameters(..), ChanParams,--    -- *Payment-    Payment,cpSignature,-    FullPayment(..),-    -- **Error-    PayChanError(..)--    -- *Bitcoin-,   BitcoinAmount-,   BitcoinLockTime(..)-,   module Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Fee--    -- *Crypto-,   SendPubKey(..),RecvPubKey(..),IsPubKey(..),--    -- *Util-    S.mkExtendedKeyRPC, rpcGetXPub, fromDate, usesBlockHeight----     PaymentChannelState,-)-where--import Data.Bitcoin.PaymentChannel.Internal.Types-import Data.Bitcoin.PaymentChannel.Internal.Serialization ()--import qualified Data.Bitcoin.PaymentChannel.Internal.State as S-import qualified Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Script as Script-import Data.Bitcoin.PaymentChannel.Internal.Error (PayChanError(..))-import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Fee--import qualified  Data.Serialize as Bin-import qualified  Network.Haskoin.Crypto as HC-import qualified  Network.Haskoin.Transaction as HT-import            Data.Word (Word64)----- |Get various information about an open payment channel.-class PaymentChannel a where-    -- |Get amount received by receiver/left for sender-    valueToMe           :: a -> BitcoinAmount-    -- |Retrieve internal state object-    getChannelState     :: a -> PaymentChannelState-    getChannelFunding   :: a -> HT.OutPoint-    getExpirationDate   :: a -> BitcoinLockTime-    getSenderPubKey     :: a -> SendPubKey-    getFundingAmount    :: a -> BitcoinAmount-    getPaymentCount     :: a -> Word64-    fundingAddress      :: a -> HC.Address-    getNewestPayment    :: a -> Payment-    getNewestSig        :: a -> HC.Signature-    -- |Return True if channel expires earlier than given expiration date-    expiresBefore       :: BitcoinLockTime -> a -> Bool-    -- |For internal use-    _setChannelState    :: a -> PaymentChannelState -> a--    channelValueLeft    :: a -> BitcoinAmount-    senderChangeValue   :: a -> BitcoinAmount-    -- |Returns 'True' if all available channel value has been transferred, 'False' otherwise-    channelIsExhausted  :: a -> Bool--    getChannelFunding       = S.pcsChannelFundingSource . getChannelState-    getExpirationDate  = S.pcsExpirationDate . getChannelState-    getSenderPubKey    = S.pcsClientPubKey . getChannelState-    getFundingAmount   = S.pcsChannelTotalValue . getChannelState-    getPaymentCount    = pcsPaymentCount . getChannelState-    fundingAddress  = Script.getP2SHFundingAddress . pcsParameters . getChannelState-    senderChangeValue  = pcsClientChangeVal . getChannelState-    channelValueLeft   = S.channelValueLeft . getChannelState-    channelIsExhausted = S.channelIsExhausted . getChannelState-    expiresBefore expDate chan = getExpirationDate chan < expDate-    getNewestPayment pcs = S.pcsGetPayment (getChannelState pcs)-    getNewestSig = psSig . cpSignature . getNewestPayment---- |State object for the value sender-data SenderPaymentChannel = CSenderPaymentChannel {-    -- |Internal state object-    spcState     ::  PaymentChannelState,-    -- |Payment-signing function-    spcSignFunc  ::  HC.Hash256 -> HC.Signature-}--instance PaymentChannel SenderPaymentChannel where-    valueToMe = channelValueLeft-    getChannelState = spcState-    _setChannelState spc s = spc { spcState = s }--instance PaymentChannel ReceiverPaymentChannel where-    valueToMe rpc@(CReceiverPaymentChannel s _) =-        S.pcsChannelTotalValue s - channelValueLeft rpc-    getChannelState = rpcState-    _setChannelState rpc s = rpc { rpcState = s }--instance Show SenderPaymentChannel where-    show (CSenderPaymentChannel s _) =-        "<SenderPaymentChannel:\n\t" ++ show s ++ ">"----- |Short-hand-type SendPayChan = SenderPaymentChannel--- |Short-hand-type RecvPayChan = ReceiverPaymentChannel--- |Short-hand-type RecvPayChanX = ReceiverPaymentChannelX--- |Short-hand-class PaymentChannel a => PayChan a-
− src/Data/Bitcoin/PaymentChannel/Util.hs 
@@ -1,66 +0,0 @@-{-|-Module      : Data.Bitcoin.PaymentChannel.Types-Copyright   : (c) Rune K. Svendsen, 2016-License     : PublicDomain-Maintainer  : runesvend@gmail.com--Utility functions for "Data.Bitcoin.PaymentChannel".---}--module Data.Bitcoin.PaymentChannel.Util-(-getFundingAddress,getRedeemScript,-setSenderChangeAddress,--serialize, deserEither,-BitcoinLockTime, parseBitcoinLocktime, toWord32, fromDate,-parseJSONInt,-pGetSig,fpGetSig,--unsafeUpdateRecvState-)-where--import Data.Bitcoin.PaymentChannel.Internal.Types-    (PaymentChannelState(..), ReceiverPaymentChannelI(..),-    Payment(..), PaymentSignature(..))-import Data.Bitcoin.PaymentChannel.Internal.Bitcoin.Script-    (getP2SHFundingAddress, getRedeemScript)-import Data.Bitcoin.PaymentChannel.Internal.Util-    (parseBitcoinLocktime, toWord32, deserEither, serialize)-import Data.Bitcoin.PaymentChannel.Internal.State-    (setClientChangeAddress)-import Data.Bitcoin.PaymentChannel.Internal.Serialization-    (parseJSONInt)--import Data.Bitcoin.PaymentChannel.Types---     (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 :: ChannelParameters -> HC.Address-getFundingAddress = getP2SHFundingAddress---- |Set new value sender change address-setSenderChangeAddress :: PaymentChannel a => a -> HC.Address -> a-setSenderChangeAddress pch addr =-    _setChannelState pch (setClientChangeAddress (getChannelState pch) addr)---- |Update internal state without signature verification.--- Useful for database-type services where a logic layer has already---  verified the signature, and it just needs to be stored.-unsafeUpdateRecvState :: ReceiverPaymentChannelI a -> Payment -> ReceiverPaymentChannelI a-unsafeUpdateRecvState (CReceiverPaymentChannel s pki) (CPayment val sig) =-    CReceiverPaymentChannel ( s { pcsClientChangeVal = val, pcsPaymentSignature = sig} ) pki--fpGetSig :: FullPayment -> HC.Signature-fpGetSig = psSig . cpSignature . fpPayment--pGetSig :: Payment -> HC.Signature-pGetSig = psSig . cpSignature
+ src/PaymentChannel.hs view
@@ -0,0 +1,293 @@+{-|+Module      : PaymentChannel+Description : Bitcoin payment channel library+Copyright   : (c) Rune K. Svendsen, 2016+License     : PublicDomain+Maintainer  : runesvend@gmail.com+Stability   : experimental+Portability : POSIX++In order to set up a payment channel between a sender and a receiver, the two parties must+ first agree on three [1] parameters for the channel:++    (1) sender public key+    (2) receiver public key+    (3) channel expiration date++ These parameters+ are contained in 'ChanParams', from which the Bitcoin address used to fund+ the payment channel can be derived using+ 'getFundingAddress'. The transaction which pays to this address is the channel funding+ transaction, and information about it is contained in a 'FundingTxInfo'.+ So, the channel funding transaction will contain an output which pays to the address returned by+ 'getFundingAddress', and once this transaction is created and in+ the blockchain, a 'ClientPayChan' and+ 'ServerPayChan' instance can be created, after first creating the 'FundingTxInfo' instance.+ 'FundingTxInfo' contains three pieces of information about the funding transaction:++    (1) hash/transaction ID+    (2) index/vout of the funding output (paying to 'getFundingAddress' address),+    (3) value of the funding output (paying to 'getFundingAddress' address)++With 'ChanParams' and 'FundingTxInfo',+ the sender can create a new 'ClientPayChanI', plus+ the first channel payment, using 'channelWithInitialPaymentOf'. 'channelWithInitialPaymentOf'+ takes two additional arguments:++    (1) a signing function which, given a hash, produces a signature that verifies against+        'cpSenderPubKey' in 'ChanParams'+    (2) the value of the first channel payment++ The sender will want to use @flip 'Network.Haskoin.Crypto.signMsg' senderPrivKey@ as the signing+ function, where @senderPrivKey@ is the private key from which 'cpSenderPubKey' is derived.+ 'channelWithInitialPaymentOf' will return the first channel 'Payment' as well as+ the new 'ClientPayChanI' state. The new state is stored, and the 'Payment'+ transferred to the receiver.++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.++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+ to the receiver by the specified amount, and an updated 'PaymentChannel.Types.ClientPayChanI' state.+ The receiver will verify and register this 'Payment' on its side using 'acceptPayment', which, on success,+ returns the value received with this payment plus the updated+ 'ServerPayChan' state object.++Payments can flow from the sender to receiver until either the channel is exhausted, or getting+ close to expiration (see important note below). In either case the receiver will use 'getSettlementBitcoinTx' to create the settlement+ Bitcoin transaction, and publish this transaction to the Bitcoin network. The settlement Bitcoin+ 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.++[1] In addition to this, two configuration options must also be agreed upon: a "dust limit",+ and a "settlement period" (measured in hours), which is subtracted from the channel expiration+ date in order to arrive at the effective (earlier) expiration date. This is necessary to give the+ server/receiver time to publish the settlement transaction before the refund transaction becomes+ valid. The dust limit is the minimum amount that the server is willing to accept+ as the client change value in the+ payment transaction. It's only relevant if the channel is+ emptied of value completely, but it is necessary because the server doesn't want to accept+ payments based on transactions it cannot publish via the Bitcoin P2P network, because they+ contain an output of minuscule value. Sensible values are contained in 'defaultConfig', but+ client/sender and server/receiver need to agree on these parameter as well, although they are+ only relevant 1) (in the case of the dust limit) if the channel is compleltely exchausted and+ 2) (in case of the "settlemend period") if the client tries to make payments close to expiration+ (and, in case the client does, it will just receive an error in response, saying the channel+ is now closed).++__/IMPORTANT:/__ /Channel setup is risk free because the sender can derive a refund Bitcoin transaction/+ /using 'getRefundBitcoinTx', which returns the bitcoins used to fund the channel back to the sender./+ /This refund transaction, however, is not valid until the expiration date specified in 'ChanParams',/+ /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/+ /6 hours before the specified channel expiration time, and possibly earlier, if the receiver wants to/+ /be cautious./++-}++module PaymentChannel+(+    -- *Initialization++    -- **Funding+    getFundingAddress,++    -- **State creation+    channelWithInitialPayment,+    channelFromInitialPayment,++    -- *Payment+    createPayment, cappedCreatePayment,+    acceptPayment,++    -- *Settlement+--     acceptClosingPayment,+    getSettlementBitcoinTx,+    getRefundBitcoinTx,++    -- *Types+    module PaymentChannel.Types+)+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)+
+ src/PaymentChannel/Internal/ChanScript.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE DeriveGeneric #-}+module PaymentChannel.Internal.ChanScript+(+  module PaymentChannel.Internal.ChanScript+, module Network.Haskoin.Script+)+where+++import PaymentChannel.Internal.Crypto.PubKey+import Bitcoin.LockTime.Util+import Bitcoin.Util+import Network.Haskoin.Script++import qualified Network.Haskoin.Internals as HI+import qualified Network.Haskoin.Crypto as HC+import qualified Data.ByteString as B+++-- |Defines channel: sender, receiver, and expiration date+data ChanParams = MkChanParams {+    cpSenderPubKey      ::  SendPubKey,+    cpReceiverPubKey    ::  RecvPubKey,+    -- |Channel expiration date/time+    cpLockTime          ::  LockTimeDate+} deriving (Eq, Show, Typeable, Generic)++instance HasSendPubKey ChanParams where+    getSendPubKey = cpSenderPubKey++instance HasRecvPubKey ChanParams where+    getRecvPubKey = cpReceiverPubKey++instance ToJSON ChanParams where+    toJSON = String . serHex . getRedeemScript++instance FromJSON ChanParams where+    parseJSON = withText "RedeemScriptHex" $+        deserHex >=> either fail return . fromRedeemScript++instance Serialize ChanParams where+    put (MkChanParams pks pkr lt) =+        put pks >> put pkr >> put lt+    get = MkChanParams <$> get <*> get <*> get++instance HasLockTimeDate ChanParams where+    getLockTimeDate MkChanParams{..} = 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{..} =+    let+        serverPubKey    = getPubKey cpReceiverPubKey+        clientPubKey    = getPubKey cpSenderPubKey+    in Script+             [OP_IF,+                 opPushData $ serialize serverPubKey, OP_CHECKSIGVERIFY,+             OP_ELSE,+                  encodeScriptLocktime cpLockTime, op_CHECKLOCKTIMEVERIFY, OP_DROP,+             OP_ENDIF,+             opPushData $ serialize clientPubKey, OP_CHECKSIG]++-- |Parse a redeemScript generated by 'mkChannelRedeemScript'+fromRedeemScript :: Script -> Either String ChanParams+fromRedeemScript (Script+            [OP_IF,+                OP_PUSHDATA serverPubKeyData OPCODE, OP_CHECKSIGVERIFY,+            OP_ELSE,+                lockTimeData, OP_NOP2, OP_DROP,    -- OP_NOP2 is OP_CHECKLOCKTIMEVERIFY+            OP_ENDIF,+            OP_PUSHDATA clientPubKeyData OPCODE, OP_CHECKSIG])+    = MkChanParams+        <$> deserEither clientPubKeyData+        <*> deserEither serverPubKeyData+        <*> decodeScriptLocktime lockTimeData+fromRedeemScript _ = Left "Unrecognized redeemScript format"+++-----Util-----++op_CHECKLOCKTIMEVERIFY = OP_NOP2++scriptToP2SHAddress :: Script -> HC.Address+scriptToP2SHAddress = HC.ScriptAddress . hash160++getP2SHFundingAddress :: ChanParams -> HC.Address+getP2SHFundingAddress = scriptToP2SHAddress . getRedeemScript++getRedeemScriptBS :: ChanParams -> B.ByteString+getRedeemScriptBS = serialize . getRedeemScript++-- Note: HI.encodeInt encodes values up to and including+-- 2^31-1 (maxBound :: Int32) as 4 bytes+-- and values 2^31 to 2^32-1 (maxBound :: Word32) as 5 bytes.+encodeScriptLocktime :: BtcLockTime lt => lt -> ScriptOp+encodeScriptLocktime =+    opPushData . B.pack . HI.cltvEncodeInt . toWord32++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+        =<< getPushBS op+  where+    -- TODO: Temporary. See https://github.com/haskoin/haskoin/issues/287+    getPushBS (OP_PUSHDATA pushBS OPCODE) = Right pushBS+    getPushBS OP_0 = Right ""+    getPushBS op = Left $ "LockTime: Expected data push, found: " ++ show op
+ src/PaymentChannel/Internal/Class/Value.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE FlexibleInstances #-}+module PaymentChannel.Internal.Class.Value where++import PaymentChannel.Internal.Payment.Types+import PaymentChannel.Internal.Payment+import PaymentChannel.Internal.Receiver.Types+import Bitcoin.Types+++class HasValue a where+    valueOf :: a -> BtcAmount++instance HasValue SignedPayment where+    valueOf SigSinglePair{..} =+        btcInValue singleInput - nonDusty (btcAmount singleOutput)++instance HasValue (PayChanState BtcSig) where+    valueOf = valueOf . pcsPayment++instance HasValue a => HasValue [a] where+    valueOf = sum . map valueOf++
+ src/PaymentChannel/Internal/Config.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE DataKinds #-}+module PaymentChannel.Internal.Config+(+  module PaymentChannel.Internal.Config+, module Bitcoin.Config+)+where++import           Bitcoin.Config+import           Data.Word+import qualified Data.Tagged as     Tag+++type Hour = Tag.Tagged "Hour" Word32++toSeconds :: Num a => Hour -> a+toSeconds = fromIntegral . (* 3600) . Tag.unTagged++configSettlePeriod :: Hour+configSettlePeriod = 10++getSettlePeriod = configSettlePeriod+getDustLimit = configDustLimit++
+ src/PaymentChannel/Internal/Crypto/PubKey.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module PaymentChannel.Internal.Crypto.PubKey+(   IsPubKey(..)+,   SendPubKey(..)+,   RecvPubKey(..)+,   HasSendPubKey(..)+,   HasRecvPubKey(..)+,   KeyDeriveIndex+,   HasKeyIndex(..)+) where++import           PaymentChannel.Internal.Util+import qualified Network.Haskoin.Crypto as HC+import           Data.Word              (Word32)+++-- |Types which contain a pubkey+class Serialize a => IsPubKey a where+    getPubKey :: a -> HC.PubKeyC++instance IsPubKey HC.PubKeyC where+    getPubKey = id++-- |Wrapper for value sender's public key+newtype SendPubKey = MkSendPubKey {+    getSenderPK    :: HC.PubKeyC+} deriving (Eq, Show, Serialize, FromJSON, ToJSON)+instance IsPubKey SendPubKey where+    getPubKey = getSenderPK++-- |Wrapper for value receiver's public key+newtype RecvPubKey = MkRecvPubKey {+    getReceiverPK  :: HC.PubKeyC+} deriving (Eq, Show, Serialize, FromJSON, ToJSON)+instance IsPubKey RecvPubKey where+    getPubKey = getReceiverPK++instance IsPubKey HC.XPubKey where+    getPubKey = HC.xPubKey++-- |Types which contain a 'SendPubKey'+class HasSendPubKey a where+    getSendPubKey :: a -> SendPubKey++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)++class HasKeyIndex a where+    getKeyIndex :: a -> KeyDeriveIndex++instance HasKeyIndex HC.XPubKey where+    getKeyIndex = KeyDeriveIndex . HC.xPubIndex++-- instance HasKeyIndex RecvPubKey where+--     getKeyIndex = getKeyIndex . getReceiverPK+
+ src/PaymentChannel/Internal/Error.hs view
@@ -0,0 +1,11 @@+module PaymentChannel.Internal.Error+(+  module PaymentChannel.Internal.Error.User+, module PaymentChannel.Internal.Error.Status+, module PaymentChannel.Internal.Error.Server+)+where++import PaymentChannel.Internal.Error.User+import PaymentChannel.Internal.Error.Status+import PaymentChannel.Internal.Error.Server
+ src/PaymentChannel/Internal/Error/Server.hs view
@@ -0,0 +1,14 @@+module PaymentChannel.Internal.Error.Server where++import Bitcoin.Types++data ReceiverError =+    SettleError BtcError+++instance Show ReceiverError where+    show (SettleError e) =+        "Settlement error: " ++ show e+++
+ src/PaymentChannel/Internal/Error/Status.hs view
@@ -0,0 +1,17 @@+module PaymentChannel.Internal.Error.Status where++import PaymentChannel.Internal.Metadata.Types++class HasHttpError a where+    getHttpError :: a -> HTTPError++type HTTPError = (Int,String)++-- instance HasHttpError PayChanStatus where+--++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")
+ src/PaymentChannel/Internal/Error/User.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE DeriveGeneric #-}++module PaymentChannel.Internal.Error.User where++import PaymentChannel.Internal.Error.Status     (HTTPError)+import Bitcoin.Compare+import PaymentChannel.Internal.Types+import PaymentChannel.Internal.Util+import           GHC.Generics++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'.+  |  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)++instance Show PayChanError where+    show SigVerifyFailed = "Signature verification failed"+    show BadSigHashFlag  = "Unexpected SIGHASH flag. Expected: SIGHASH_SINGLE|ANYONECANPAY (0x83)"+    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 (PaymentError (TxInMismatch (InPrevOutMismatch op _))) =+        "unexpected outpoint. expected: " ++ show op+    show (PaymentError (TxOutMisMatch (OutAddressMismatch addr _))) =+        "unexpected change address. expected: " ++ show addr+    show (PaymentError (TxInMismatch (InRdmScrMismatch scr _))) =+        "unexpected redeemScript. expected: " ++ cs (serHex scr)+    show (PaymentError e) = "unexpected error: " ++ show e+++-- instance Serialize PayChanError -- Generic PayChanError instance
+ src/PaymentChannel/Internal/Metadata/Types.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+module PaymentChannel.Internal.Metadata.Types where++import PaymentChannel.Internal.Util+import PaymentChannel.Internal.Settlement.Types+import Bitcoin.Amount+import PaymentChannel.Internal.Crypto.PubKey++import Data.Time.Clock    (UTCTime)+import GHC.Generics       (Generic)+import Data.Typeable+++data MetadataI kd = Metadata+    { mdKeyData         :: kd+    , mdPayCount        :: Word64+    , mdSettledValue    :: [SettleInfo]+    , mdUnsettledValue  :: BtcAmount+    , mdChannelStatus   :: PayChanStatus+    } deriving (Eq, Typeable, Show, Generic)++type MetadataIdx = MetadataI KeyDeriveIndex++data PayChanStatus =+    ReadyForPayment+  | PaymentInProgress+  | SettlementInProgress+  | ChanClosed+    deriving (Eq, Typeable, Show, Read, Generic, Serialize)++instance Serialize a => Serialize (MetadataI a) where+    put Metadata{..} =+           put mdKeyData+        >> put mdPayCount+        >> put mdSettledValue+        >> put mdUnsettledValue+        >> 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)+
+ src/PaymentChannel/Internal/Metadata/Util.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE RecordWildCards #-}+module PaymentChannel.Internal.Metadata.Util+(+  module PaymentChannel.Internal.Metadata.Util+, module PaymentChannel.Internal.Metadata.Types+, module PaymentChannel.Internal.Types+)+where++import PaymentChannel.Internal.Types+import PaymentChannel.Internal.Metadata.Types+import PaymentChannel.Internal.Settlement.Util+-- import qualified PaymentChannel.Internal.State as S+++metaSetStatus :: PayChanStatus -> MetadataI a -> MetadataI a+metaSetStatus s md = md { mdChannelStatus = s }++metaGetStatus :: MetadataI a -> PayChanStatus+metaGetStatus Metadata{ mdChannelStatus = s } = s++metaTotalValXfer :: MetadataI a -> BtcAmount+metaTotalValXfer Metadata{..} =+    sum (map siValue mdSettledValue) + mdUnsettledValue
+ src/PaymentChannel/Internal/Payment.hs view
@@ -0,0 +1,9 @@+module PaymentChannel.Internal.Payment+(+  module Export+)+where++import PaymentChannel.Internal.Payment.Types    as Export+import PaymentChannel.Internal.Payment.Create   as Export+import PaymentChannel.Internal.Payment.Verify   as Export
+ src/PaymentChannel/Internal/Payment/Create.hs view
@@ -0,0 +1,56 @@+module PaymentChannel.Internal.Payment.Create+(+  mkUnsignedPayment+, createPaymentOfValue+, module Export+)+where++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++++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)++createPaymentOfValue :: ( Monad m, Show t+                        , TransformSigData BtcSig () r+                        , SignatureScript t BtcSig+                        , SpendFulfillment BtcSig r+                        , HasSpendCond r t+                        ) =>+       HC.PrvKeyC+    -> SigSinglePair t ()+    -> BtcAmount+    -> m (Either BtcError (SigSinglePair t BtcSig))+createPaymentOfValue prvKey ssp payVal =+    either (return . Left) (signPair prvKey) (decrementClientValue ssp payVal)++decrementClientValue :: SigSinglePair r () -> BtcAmount -> Either BtcError (SigSinglePair r ())+decrementClientValue sp@SigSinglePair{..} decVal = do+    newVal <- mkNonDusty (currentVal - decVal)+    Right $ sp { singleOutput = replaceValue singleOutput newVal }+  where+    currentVal = nonDusty $ btcAmount singleOutput+    replaceValue out val = out { btcAmount = val }+
+ src/PaymentChannel/Internal/Payment/Types.hs view
@@ -0,0 +1,52 @@+module PaymentChannel.Internal.Payment.Types+(+  module PaymentChannel.Internal.Payment.Types+, module PaymentChannel.Internal.Types+, module Bitcoin.SpendCond.Cond+)+where++import PaymentChannel.Internal.Types+import Bitcoin.Types+import Bitcoin.SinglePair+import Bitcoin.SpendCond.Cond+import Bitcoin.Signature++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++++-- | scriptInput for a settlement transaction using client+server pubkey+data PaymentScriptSig = PaymentScriptSig+    { sssClientSig   :: BtcSig+    , sssServerSig   :: BtcSig+    }++instance TransformSigData BtcSig () ChanParams where+    mkSigData _ btcSig _ = btcSig++instance TransformSigData PaymentScriptSig BtcSig ChanParams where+    mkSigData clientSig serverSig _ = PaymentScriptSig clientSig serverSig++-- Two signatures+instance SpendFulfillment PaymentScriptSig ChanParams where+    rawSigs PaymentScriptSig{..} MkChanParams{..} =+        [ (getPubKey cpReceiverPubKey, sssClientSig)+        , (getPubKey cpSenderPubKey  , sssServerSig) ]+    signatureScript PaymentScriptSig{..} _ = Script+        [ opPush sssClientSig+        , opPush sssServerSig+        , OP_1]   -- Make OP_IF in reeemScript evaluate to true (two pubkeys/sigs)++-- Single (client) signature+instance SpendFulfillment BtcSig ChanParams where+    rawSigs clientSig MkChanParams{..} =+        [ (getPubKey cpSenderPubKey, clientSig) ]+    signatureScript _ _ = Script [] --TODO: separate rawSigs from signatureScript?+++instance SpendCondition ChanParams where+    conditionScript = getRedeemScript
+ src/PaymentChannel/Internal/Payment/Verify.hs view
@@ -0,0 +1,64 @@+module PaymentChannel.Internal.Payment.Verify+(+  paymentValueIncrease+)+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 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+++paymentValueIncrease :: MonadTime m =>+       Payment BtcSig+    -> Payment BtcSig+    -> m (Either PayChanError BtcAmount)+paymentValueIncrease sp1 sp2 = do+    fundingLocked <- fundingIsLocked sp2+    if fundingLocked then return checkedPayVal else return $ Left ChannelExpired+  where+    checkedPayVal = do+            valRecvd <- payValIncrease sp1 sp2+            _ <- fmapL (const SigVerifyFailed) (singlePairVerifySig sp2)+            return valRecvd++payValIncrease ::+       Payment BtcSig+    -> Payment BtcSig+    -> Either PayChanError BtcAmount+payValIncrease sp1 sp2 =+    comparePayments sp1 sp2 >>=+    \res -> case res of+        -- Inspect change in client change value.+        -- A decrease in client change value is an increase in value to us.+        DiffInfo [(_, Decrease val)] -> Right val+        DiffInfo [(_, NoChange)]     -> Right 0+        DiffInfo [(_, Increase val)] -> Left $ BadPaymentValue val+        DiffInfo x -> error $ "Not exactly one output in a 'Payment': " ++ show x++comparePayments ::+       Payment BtcSig+    -> Payment BtcSig+    -> Either PayChanError DiffInfo+comparePayments sp1 sp2 =+    fmapL PaymentError (valueDiff tx1 tx2) >>= eqIgnoreVal+  where+    (tx1,tx2) = (toBtcTx sp1, toBtcTx sp2)+    eqIgnoreVal di =+        if not $ eqIgnoreOutVal (IgnoreSigData tx1) (IgnoreSigData tx2)+            then Left BadSigHashFlag  -- Means sig hash flags differ+            else Right di
+ src/PaymentChannel/Internal/RBPCP/Parse.hs view
@@ -0,0 +1,57 @@+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+        }++
+ src/PaymentChannel/Internal/Receiver/Settle.hs view
@@ -0,0 +1,41 @@+module PaymentChannel.Internal.Receiver.Settle where++import PaymentChannel.Types+import PaymentChannel.Internal.Receiver.Types+import Bitcoin.Types+import qualified PaymentChannel.Internal.Settlement.Util as Settle+import PaymentChannel.Internal.Error+import PaymentChannel.Internal.Payment+import PaymentChannel.Internal.Metadata.Util+import qualified Network.Haskoin.Crypto as HC+import qualified Network.Haskoin.Transaction as HT+++newMetaAfterSettle :: ServerPayChanI a -> MetadataI a+newMetaAfterSettle rpc@MkServerPayChan{rpcMetadata = prevMd} =+    prevMd+        { mdSettledValue   = Settle.infoFromState rpc : mdSettledValue prevMd :: [Settle.SettleInfo]+        , mdUnsettledValue = 0+        , mdChannelStatus  = statusAfterSettlement rpc+        }++-- |What would the status of the payment channel be+--   if the settlement transaction were published right now?+statusAfterSettlement :: ServerPayChanI a -> PayChanStatus+statusAfterSettlement rpc@MkServerPayChan{rpcState = pcs} =+    if changeAddress pcs /= fundingAddress rpc then     -- channelIsExhausted+        ChanClosed+    else+        ReadyForPayment+  where+    changeAddress = clientChangeAddr . pcsPayment++-- settleChanState :: SignedBtcTx ChanParams -> ServerPayChanI a -> ServerPayChanI a+-- settleChanState tx rpc@MkServerPayChan{rpcState = pcs} =+--     undefined+--         where+--             clientOutM = listToMaybe $ filter ()+--             newFti = CFundingTxInfo h i (pcsClientChangeVal pcs)+--             newPCS = pcs { pcsFundingTxInfo = newFti, pcsPaymentCount = 0 }++
+ src/PaymentChannel/Internal/Receiver/Types.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+module PaymentChannel.Internal.Receiver.Types+(+  module PaymentChannel.Internal.Receiver.Types+, module PaymentChannel.Internal.Types+, module PaymentChannel.Internal.State+)+where++import PaymentChannel.Internal.State+import PaymentChannel.Internal.Types+import PaymentChannel.Internal.Metadata.Types+import PaymentChannel.Internal.Util+++-- |ServerPayChan without receiver key metadata+type ServerPayChan = ServerPayChanI ()+-- |ServerPayChan with BIP32, "extended key" index as metadata+type ServerPayChanX = ServerPayChanI KeyDeriveIndex++-- |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 {+    -- |Internal state object+    rpcState    :: PayChanState BtcSig+  , rpcMetadata :: MetadataI kd+} deriving (Eq, Show, Typeable, Generic, Serialize)++instance HasSendPubKey (ServerPayChanI a) where getSendPubKey = getSendPubKey . rpcState+instance HasRecvPubKey (ServerPayChanI a) where getRecvPubKey = getRecvPubKey . rpcState++++instance ToJSON d => ToJSON (ServerPayChanI d) where+    toJSON rpc = object+        [ "state"       .= rpcState rpc+        , "metadata"    .= rpcMetadata rpc+        ]++instance FromJSON d => FromJSON (ServerPayChanI d) where+    parseJSON = withObject "ServerPayChanI" $ \o ->+        MkServerPayChan <$>+            o .: "state" <*>+            o .: "metadata"++
+ src/PaymentChannel/Internal/Receiver/Util.hs view
@@ -0,0 +1,79 @@+module PaymentChannel.Internal.Receiver.Util+(+  module PaymentChannel.Internal.Receiver.Util+, module PaymentChannel.Internal.Receiver.Types+, module PaymentChannel.Internal.Class.Value+)+where++import PaymentChannel.Internal.Class.Value+import PaymentChannel.Internal.Receiver.Types+import qualified PaymentChannel.Internal.Settlement.Util as Settle+import PaymentChannel.Internal.Error+import PaymentChannel.Internal.Payment+import PaymentChannel.Internal.Metadata.Util+import PaymentChannel.Internal.Class.Value     (HasValue(..))+import qualified Network.Haskoin.Crypto as HC++++-- KeyDeriveIndex++-- |Create a 'ServerPayChanX', which has an associated BIP32 key index, from a+--  'ServerPayChan'+mkExtendedKeyRPC :: ServerPayChanI a -> HC.XPubKey -> 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+        else+            Nothing++mkExtendedKeyRPCUnsafe :: Word32 -> ServerPayChanI a -> ServerPayChanX+mkExtendedKeyRPCUnsafe i rpc =+    rpc {+        rpcMetadata =+            Metadata (fromIntegral i) 0 [] (valueOf $ rpcState rpc) ReadyForPayment+        }++mkDummyExtendedRPC :: ServerPayChanI a -> ServerPayChanX+mkDummyExtendedRPC = mkExtendedKeyRPCUnsafe 0++metaKeyIndex :: ServerPayChanI KeyDeriveIndex -> KeyDeriveIndex+metaKeyIndex = mdKeyData . rpcMetadata+++-- Status+setChannelStatus :: PayChanStatus -> ServerPayChanI a -> ServerPayChanI a+setChannelStatus s pcs@MkServerPayChan{ rpcMetadata = meta } =+    pcs { rpcMetadata = metaSetStatus s meta }++getChannelStatus :: ServerPayChanI a -> PayChanStatus+getChannelStatus MkServerPayChan{ rpcMetadata = meta } =+    metaGetStatus meta++markAsBusy :: ServerPayChanI a -> ServerPayChanI a+markAsBusy = setChannelStatus PaymentInProgress++isReadyForPayment :: ServerPayChanI a -> Bool+isReadyForPayment =+    (== ReadyForPayment) . getChannelStatus++checkChannelStatus :: ServerPayChanI a -> Either PayChanError (ServerPayChanI a)+checkChannelStatus rpc =+    maybe+    (Right rpc)+    (Left . StatusError)+    (checkReadyForPayment $ getChannelStatus rpc)+++-- Metadata+calcNewData :: MetadataI a -> PayChanState BtcSig -> MetadataI a+calcNewData md@Metadata{ mdUnsettledValue = oldValRecvd, mdPayCount = oldCount } pcs =+    md { mdUnsettledValue = checkedVal, mdPayCount = oldCount+1 }+    where checkedVal  = if newValRecvd < oldValRecvd then error "BUG: Value lost :(" else newValRecvd+          newValRecvd = valueOf pcs++updateMetadata :: ServerPayChanI a -> ServerPayChanI a+updateMetadata rpc@MkServerPayChan{..} =+    rpc { rpcMetadata = calcNewData rpcMetadata rpcState }
+ src/PaymentChannel/Internal/Refund.hs view
@@ -0,0 +1,52 @@+module PaymentChannel.Internal.Refund where++import PaymentChannel.Internal.Settlement.Types+import PaymentChannel.Internal.Payment.Create+import Bitcoin.Signature++import qualified Network.Haskoin.Transaction as HT+import qualified Network.Haskoin.Script as HS+import qualified Network.Haskoin.Crypto as HC++++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.+mkBaseRefundTx :: ChanParams -> FundingTxInfo -> UnsignedRefundTx+mkBaseRefundTx cp CFundingTxInfo{..} =+    let+        baseIn = setSignFlag (HS.SigAll False) $ mkNoSigTxIn+                             (HT.OutPoint ftiHash ftiOutIndex)+                             (nonDusty ftiOutValue)+                             (Pay2 $ ScriptHash $ Cond cp)+        -- If the sequence field equals maxBound (0xffffffff),+        --  lockTime features are disabled. so we subtract one+        refundIn  = setSequence (maxBound-1) baseIn+        baseTx    = mkBtcTx (refundIn :| []) []+    in+        setLockTime (cpLockTime cp) baseTx++mkRefundTx+    :: Monad m+    => HC.PrvKeyC+    -> ChanParams+    -> FundingTxInfo+    -> 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+        where+            refundTx  = mkBaseRefundTx cp fti+            changeOut = mkChangeOut refundAddr txFee KeepDust+            signFunc _ = return prvKey++++
+ src/PaymentChannel/Internal/Serialization.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving, TypeSynonymInstances, FlexibleInstances #-}+module PaymentChannel.Internal.Serialization+(+  module PaymentChannel.Internal.Serialization.Orphans+) where++import PaymentChannel.Internal.Serialization.Orphans ()
+ src/PaymentChannel/Internal/Serialization/JSON.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE OverloadedStrings, RecordWildCards #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+module PaymentChannel.Internal.Serialization.JSON where++import           Data.Aeson.Types   (Parser)+import           Data.Scientific    (Scientific, toBoundedInteger)+import           Data.Word          (Word64)+import           Data.Typeable      (Typeable, typeOf)++parseJSONWord :: forall i. (Typeable i, Integral i, Bounded i) => Scientific -> Parser i+parseJSONWord s =+    case toBoundedInteger s of+        Just w -> return w+        Nothing -> fail $  "failed to decode "+                        ++ show (typeOf (undefined :: i))+                        ++ " from JSON number. data: " ++ show s+
+ src/PaymentChannel/Internal/Serialization/Orphans.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+module PaymentChannel.Internal.Serialization.Orphans where++import           PaymentChannel.Internal.Util+import           PaymentChannel.Internal.Error++import qualified Data.Time.Clock    as Clock+import qualified Data.Time.Clock.POSIX as Clock+++instance Serialize Clock.UTCTime where+    put t = putWord64be (round $ Clock.utcTimeToPOSIXSeconds t)+    get = Clock.posixSecondsToUTCTime . fromIntegral <$> getWord64be
+ src/PaymentChannel/Internal/Settlement.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE RecordWildCards, FlexibleContexts #-}+module PaymentChannel.Internal.Settlement+-- (+--     createSignedSettlementTx+-- ,   settleReceivedValue+-- ,   UnsignedSettlementTx, mkUnsignedSettleData+-- )+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 qualified Data.List.NonEmpty     as NE+{-# ANN module ("HLint: ignore Use mapMaybe"::String) #-}++++type SignedTx = BtcTx (P2SH ChanParams) PaymentScriptSig+++mkUnsignedSettleData ::+       NE.NonEmpty ServerPayChanX+    -> [BtcOut]+    -> ClientSignedTx+mkUnsignedSettleData rpcL extraOuts =+    txAddOuts extraOuts $ toClientSignedTx payLst+        where payLst = NE.map (pcsPayment . rpcState) rpcL+++getSignedSettlementTx :: Monad m =>+       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++++++
+ src/PaymentChannel/Internal/Settlement/Config.hs view
@@ -0,0 +1,7 @@+module PaymentChannel.Internal.Settlement.Config where++import qualified Network.Haskoin.Script as HS++-- |Sign everything, and do not allow additional inputs to be added afterwards.+serverSigHash :: HS.SigHash+serverSigHash = HS.SigAll False
+ src/PaymentChannel/Internal/Settlement/Script.hs view
@@ -0,0 +1,9 @@+module PaymentChannel.Internal.Settlement.Script where++import PaymentChannel.Internal.Util+import PaymentChannel.Internal.Types+import qualified Network.Haskoin.Crypto as HC+import qualified Network.Haskoin.Script as HS+++
+ src/PaymentChannel/Internal/Settlement/Types.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE FlexibleContexts, DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+module PaymentChannel.Internal.Settlement.Types+(+  module PaymentChannel.Internal.Settlement.Types+, module PaymentChannel.Internal.Payment.Types+, module PaymentChannel.Internal.Settlement.Config+)+where++import PaymentChannel.Internal.Settlement.Script+import Bitcoin.Util+import PaymentChannel.Internal.Payment.Types+import PaymentChannel.Internal.Settlement.Config++import qualified Network.Haskoin.Crypto             as HC+import qualified Network.Haskoin.Script             as HS+import           Data.Word                          (Word64)+import           Data.Time.Clock                    (UTCTime)+{-# ANN module ("HLint: ignore Use mapMaybe"::String) #-}++++data RefundScriptSig = RefundScriptSig+   { rssClientSig   :: BtcSig+   }+++instance HasLockTimeDate (P2SH ChanParams) where+    getLockTimeDate = cpLockTime . getCond++instance SpendFulfillment RefundScriptSig ChanParams where+    rawSigs RefundScriptSig{..} MkChanParams{..} =+        [ (getPubKey cpReceiverPubKey, rssClientSig) ]+    signatureScript RefundScriptSig{..} _ = Script+        [ opPush rssClientSig+        , OP_0 ] -- Make reeemScript OP_IF evaluate to false.+                 -- Signal that we want to provide only one pubkey/sig pair (sender's),+                 -- after it is checked that the lockTime has expired.++++-- |After a settlement transaction is published, we save+--   certain properties from the old state object before+--   it's replaced with a new one.+data SettleInfo = SettleInfo+    { siValue       :: BtcAmount+    , siPayCount    :: Word64+    } deriving (Eq, Show, Generic, Serialize, FromJSON, ToJSON)++++type ClientSignedTx = BtcTx (P2SH ChanParams) BtcSig
+ src/PaymentChannel/Internal/Settlement/Util.hs view
@@ -0,0 +1,21 @@+module PaymentChannel.Internal.Settlement.Util+(+  module PaymentChannel.Internal.Settlement.Util+, module PaymentChannel.Internal.Settlement.Types+) where++import PaymentChannel.Internal.Util+import PaymentChannel.Internal.Payment+import qualified PaymentChannel.Internal.ChanScript as S+import PaymentChannel.Internal.Settlement.Types+import PaymentChannel.Internal.Receiver.Types+import PaymentChannel.Internal.Class.Value     (HasValue(..))+import qualified Network.Haskoin.Crypto as HC+import qualified Network.Haskoin.Script as HS+import qualified Data.List.NonEmpty     as NE+++++infoFromState :: ServerPayChanI a -> SettleInfo+infoFromState rpc = error "STUB" -- SettleInfo (error "STUB") (mdPayCount $ rpcMetadata rpc)
+ src/PaymentChannel/Internal/State.hs view
@@ -0,0 +1,72 @@+{-# 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+
+ src/PaymentChannel/Internal/Types.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE OverloadedStrings, RecordWildCards #-}+{-# 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+) where++import PaymentChannel.Internal.Config           as X+import PaymentChannel.Internal.Util             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           Network.Haskoin.Transaction hiding (signTx)++import           Network.Haskoin.Crypto hiding (DerivPathI(..), PubKey, hash160, hash256)++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           Data.Word+import           Data.List.NonEmpty         (NonEmpty(..))+import           GHC.Generics               (Generic)+import           Data.Maybe                 (fromMaybe)+import Control.Monad.Time++type Payment = SigSinglePair (P2SH ChanParams)+type SignedPayment   = Payment BtcSig+type UnsignedPayment = Payment ()++instance HasSendPubKey (Payment a) where getSendPubKey = getSendPubKey . pairRedeemScript+instance HasRecvPubKey (Payment a) where getRecvPubKey = getRecvPubKey . pairRedeemScript++instance HasLockTimeDate (Payment a) where+    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+    } deriving (Eq, Show, Typeable, Generic, Serialize, ToJSON, FromJSON)++instance HasSendPubKey (PayChanState a) where getSendPubKey = getSendPubKey . pcsPayment+instance HasRecvPubKey (PayChanState a) where getRecvPubKey = getRecvPubKey . pcsPayment++type EmptyClientPayChan = ClientPayChanI ()+type ClientPayChan = ClientPayChanI BtcSig++-- |State object for the value sender+data ClientPayChanI sigData = MkClientPayChan+    { -- |Internal state object+      spcState    :: PayChanState sigData+    , -- |Payment-signing function+      spcPrvKey   :: HC.PrvKeyC+    } -- deriving (Eq, Show, Typeable, Generic, Serialize, ToJSON, FromJSON)++instance HasSendPubKey (ClientPayChanI a) where getSendPubKey = getSendPubKey . spcState+instance HasRecvPubKey (ClientPayChanI a) where getRecvPubKey = getRecvPubKey . spcState++-- |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).+} deriving (Eq, Show, Typeable, Generic)++++instance Serialize FundingTxInfo where+    put (CFundingTxInfo h idx val) =+        put h >> putWord32be idx >> put val+    get = CFundingTxInfo <$> get <*> getWord32be <*> get++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 FromJSON HC.Hash256 where+    parseJSON = withText "Hash256" (either fail return . decode . fst . B16.decode . cs)++instance Show ClientPayChan where+    show (MkClientPayChan s _) =+        "<ClientPayChanI:\n\t" ++ show s ++ ">"
+ src/PaymentChannel/Internal/Util.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE ScopedTypeVariables #-}++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+,   Typeable+,   Int64+,   module Tagged+,   cs+,   fmapL+,   (<>)+,   module Ctrl+)+where++import PaymentChannel.Internal.Serialization.JSON as JSONUtil+++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+++mkDummySig :: B.ByteString -> HC.Signature+mkDummySig hexStr =+    fromMaybe (error "dummySig: Invalid dummy sig data") (HC.decodeDerSig sigBS)+        where sigBS = fst $ B16.decode hexStr++dummySig = mkDummySig "304402204202cdb61cb702aa62de312a8e5eada817d90c4e26c8b696780b14d1576f204f02203c134d0acb057d917508ca9baab241a4f66ebea32f7acceeaf621a334927e17701"
+ src/PaymentChannel/Test.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+module PaymentChannel.Test+(+    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 Network.Haskoin.Crypto as HC+import           Network.Haskoin.Test+import           Data.Time.Clock                 (UTCTime(..))+import           Data.Time.Calendar              (Day(..))+import           Control.Monad                   (foldM)++import Test.QuickCheck+++maxCoins :: Integer+maxCoins = round $ (21e6 :: Double) * 1e8++mIN_CHANNEL_SIZE :: BtcAmount+mIN_CHANNEL_SIZE = configDustLimit * 2+++data ArbChannelPair = ArbChannelPair+    { sendChan          :: ClientPayChan+    , recvChan          :: ServerPayChan+    , initPayAmount     :: BtcAmount+    , initRecvAmount    :: BtcAmount+    , initPayment       :: SignedPayment+    , recvPrvKey        :: HC.PrvKeyC+    }++data ChannelPairResult = ChannelPairResult+    { resInitPair       :: ArbChannelPair+    , resSendChan       :: ClientPayChan+    , resRecvChan       :: ServerPayChan+    , resSentAmounts    :: [BtcAmount]+    , resRecvdAmounts   :: [BtcAmount]+    , resPayList        :: [SignedPayment]+    }++instance Show ArbChannelPair where+    show (ArbChannelPair spc rpc _ _ _ _) =+        "SendState: " ++ show spc ++ "\n" +++        "RecvState: " ++ show rpc++instance Arbitrary ArbChannelPair where+    arbitrary = fmap fst mkChanPair++instance Arbitrary ClientPayChan where+    arbitrary = fmap (sendChan . fst) mkChanPair++instance Arbitrary ServerPayChan where+    arbitrary = fmap (recvChan . fst) mkChanPair++instance Arbitrary (PayChanState BtcSig) where+    arbitrary = fmap rpcState (arbitrary :: Gen ServerPayChan)++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)++newtype NonZeroBitcoinAmount = NonZeroBitcoinAmount { getAmount :: BtcAmount }++instance Arbitrary NonZeroBitcoinAmount where+    arbitrary = (NonZeroBitcoinAmount . fromIntegral) <$>+        choose (1, maxCoins)++instance Arbitrary (Payment BtcSig) where+    arbitrary = snd <$> mkChanPair++instance MonadTime Gen where+    currentTime = return nowishTimestamp+++toInitResult :: ArbChannelPair -> ChannelPairResult+toInitResult initPair@(ArbChannelPair spc rpc payAmt rcvAmt pay _) =+    ChannelPairResult initPair spc rpc [payAmt] [rcvAmt] [pay]+++-- |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+    case eitherRpc of+        Left e -> error (show e)+        Right (recvAmount, newRpc) -> return $+            ChannelPairResult initPair newSpc newRpc+                (amountSent : sendList)+                (recvAmount : recvList)+                (pmn : payLst)++runChanPair :: MonadTime m => ArbChannelPair -> [BtcAmount] -> m ChannelPairResult+runChanPair chanPair paymentAmountList =+    foldM doPayment (toInitResult chanPair) paymentAmountList++mkChanParams :: Gen (ChanParams, (HC.PrvKeyC, HC.PrvKeyC))+mkChanParams = do+    -- sender key pair+    ArbitraryPubKeyC sendPriv sendPK <- arbitrary+    -- receiver key pair+    ArbitraryPubKeyC recvPriv recvPK <- arbitrary+--     ArbitraryXPubKey recvPriv recvPK <- arbitrary+    -- 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))++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 (sendChan,initPayment) = either (error . show) id sendChanE+    recvChanE <- channelFromInitialPayment cp fti initPayment+    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)+++-- TODO: We don't bother testing expiration time for now+nowishTimestamp :: UTCTime+nowishTimestamp = UTCTime (ModifiedJulianDay 50000) 0
+ src/PaymentChannel/Types.hs view
@@ -0,0 +1,174 @@+{-|+Module      : PaymentChannel.Types+Copyright   : (c) Rune K. Svendsen, 2016+License     : PublicDomain+Maintainer  : runesvend@gmail.com++Types used with the interface provided by "PaymentChannel".++-}++{-# LANGUAGE RecordWildCards, TypeSynonymInstances, FlexibleInstances #-}++module PaymentChannel.Types+(+    -- *Shared sender/receiver types/functions+    FundingTxInfo(..)+  , ChanParams(..)+  , PaymentChannel(..), PayChan+  , PaymentChannelRecv(..)+--   , getChannelFunding+--   , getExpirationDate+--   , getFundingAmount+--   , getPaymentCount+  , fundingAddress+  , clientChangeAddress+  , availableChannelVal+--   , getNewestPayment+--   , getNewestSig+--   , senderChangeValue+--   , channelValueLeft+--   , chanIsExhausted+--   , expiresBefore+--   , getChannelState++    -- *Sender state+  , ClientPayChanI(..)++    -- *Receiver state+  , ServerPayChan, ServerPayChanI(rpcMetadata)+  , PayChanStatus(..)+  , S.getChannelStatus, S.setChannelStatus+  , S.markAsBusy, S.isReadyForPayment++    -- *Receiver state (with pubkey metadata)+  , ServerPayChanX+  , S.mkExtendedKeyRPC, S.metaKeyIndex++    -- *Payment+  , Payment+--   , paySignature,payClientChange+--   , FullPayment(..)+    -- **Error+  , PayChanError(..)++    -- *Bitcoin+  , BtcAmount+  , BtcLockTime(..)+  , module Bitcoin.Fee++    -- *Crypto+  , SendPubKey(..),RecvPubKey(..),IsPubKey(..),HasSendPubKey(..),HasRecvPubKey(..)++    -- *Util+  , fromDate+  , getChanState+--  , usesBlockHeight, dummyPayment++    -- *Config settings+  , getSettlePeriod, getDustLimit++)+where++import PaymentChannel.Internal.Types+import PaymentChannel.Internal.Receiver.Types+import PaymentChannel.Internal.Metadata.Util+import PaymentChannel.Internal.Serialization ()+import PaymentChannel.Internal.Class.Value     (HasValue(..))++import qualified PaymentChannel.Internal.Receiver.Util as S+import qualified PaymentChannel.Internal.ChanScript as Script+import PaymentChannel.Internal.Error (PayChanError(..))+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++-- 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++-- getPaymentCount :: HasPayChanState a => a -> Word64+-- getPaymentCount = pcsPayCount . getPayChanState++fundingAddress :: HasPayChanState a => a -> HC.Address+fundingAddress = Script.getP2SHFundingAddress . pairRedeemScript . pcsPayment . getPayChanState++-- getNewestPayment :: HasPayChanState a => a -> Payment+-- getNewestPayment pcs = S.pcsGetPayment (getPayChanState pcs)++-- getNewestSig  :: HasPayChanState a => a -> HC.Signature+-- getNewestSig = bsSig . paySignature . getNewestPayment++-- senderChangeValue :: HasPayChanState a => a -> BtcAmount+-- senderChangeValue = pcsClientChangeVal . 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+    -- |Get amount received by receiver/left for sender+    valueToMe :: a -> BtcAmount+    -- |For internal use+    _setChannelState :: a -> PayChanState BtcSig -> a++-- clientChangeVal++instance PaymentChannel ClientPayChan where+    valueToMe = clientChangeVal . pcsPayment . spcState+    _setChannelState spc s = spc { spcState = s }++instance PaymentChannel (ServerPayChanI s) where+    valueToMe (MkServerPayChan s _) = valueOf s+    _setChannelState rpc s = rpc { rpcState = s }+++-- |Payment channel state objects with metadata information+class PaymentChannel a => PaymentChannelRecv a where+    -- |Get total amount (both settled and unsettled) sent by client+    clientTotalValueSent :: a -> BtcAmount++instance PaymentChannelRecv (ServerPayChanI (MetadataI a)) where+    clientTotalValueSent = metaTotalValXfer . rpcMetadata++++-- |Short-hand+class PaymentChannel a => PayChan a+
+ src/PaymentChannel/Util.hs view
@@ -0,0 +1,37 @@+{-|+Module      : PaymentChannel.Types+Copyright   : (c) Rune K. Svendsen, 2016+License     : PublicDomain+Maintainer  : runesvend@gmail.com++Utility functions for "PaymentChannel".++-}++module PaymentChannel.Util+(+getFundingAddress,Scr.getRedeemScript,++serialize, deserEither,+BtcLockTime, parseLockTime, toWord32, fromDate,+Ser.parseJSONWord,+)+where++import PaymentChannel.Internal.Receiver.Types+import Bitcoin.Util+import qualified PaymentChannel.Internal.Serialization.JSON    as Ser+import qualified PaymentChannel.Internal.ChanScript        as Scr++import PaymentChannel.Types+--     (ChanParams, FundingTxInfo)++import qualified Network.Haskoin.Crypto as HC++-- | Derive a Bitcoin address, for funding a payment channel, from+--  'ChanParams'.+--  The transaction which pays to this address is the channel funding transaction,+--  and information about this transaction is contained in+--  'FundingTxInfo'.+getFundingAddress :: ChanParams -> HC.Address+getFundingAddress = Scr.getP2SHFundingAddress
test/Main.hs view
@@ -1,100 +1,165 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, RecordWildCards, GeneralizedNewtypeDeriving, DeriveFunctor #-} module Main where -import           Data.Bitcoin.PaymentChannel.Test-import           Data.Bitcoin.PaymentChannel.Util+import           PaymentChannel.Test+import           PaymentChannel.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 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                       (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 -testAddrTestnet :: HC.Address-testAddrTestnet = "2N414xMNQaiaHCT5D7JamPz7hJEc9RG7469"++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 = defaultMain tests+main = putStrLn "" >> defaultMain tests  tests :: [Test] tests =     [ testGroup "Payment"-        [ testProperty "Sender value in settlement tx" $-            testPaymentSession checkSenderValue-        , testProperty "Receiver value in settlement tx" $-            testPaymentSession checkReceiverValue-        , testProperty "Sender/receiver state match" $-            testPaymentSession checkSendRecvStateMatch-        , testProperty "Sent amount == received amount" $-            testPaymentSession checkRecvSendAmount-        ]-    , testGroup "Serialization"-        [ testGroup "JSON"-            [ testProperty "FullPayment"-                (jsonSerDeser :: FullPayment -> Bool)+        [ testGroup "State"+            [ testProperty "Sender/receiver match" $+              testPaymentSessionM checkSendRecvStateMatch+            , testProperty "Sent amount == received amount" $+              testPaymentSessionM checkRecvSendAmount             ]-        , testGroup "Binary"-            [ testProperty "FullPayment"-                (binSerDeser  :: FullPayment -> Bool)-            , testProperty "PaymentChannelState"-                (binSerDeser  :: PaymentChannelState -> Bool)-            , testProperty "ChanScript"-               (binSerDeser  :: ChanScript -> Bool)+        , 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 -checkSenderValue :: (ArbChannelPair, [BitcoinAmount]) -> Bool-checkSenderValue (ArbChannelPair _ recvChan amountSent _ recvSignFunc, _) = do-    let settleTx = getSettlementBitcoinTx recvChan testAddrLivenet recvSignFunc (0 :: BitcoinAmount)-    let clientChangeAmount = HT.outValue . head . HT.txOut $ settleTx+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 fundAmountMinusPaySum = pcsChannelTotalValue (getChannelState recvChan) --            fromIntegral (sum amountSent)-    fromIntegral clientChangeAmount == fundAmountMinusPaySum+    let fundingVal = fundingValue $ pcsPayment (getChanState resRecvChan)+        fundValMinusPaym = fundingVal - fromIntegral (sum resSentAmounts)+    return $ fromIntegral clientChangeAmount == fundValMinusPaym -checkReceiverValue :: (ArbChannelPair, [BitcoinAmount]) -> Bool-checkReceiverValue (ArbChannelPair _ recvChan amountSent _ recvSignFunc, _) = do-    let settleTx = getSettlementBitcoinTx recvChan testAddrLivenet recvSignFunc (0 :: BitcoinAmount)-    let receiverAmount = HT.outValue (HT.txOut settleTx !! 1)+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.-    (fromIntegral receiverAmount :: BitcoinAmount) == fromIntegral (sum amountSent)+    return $ (fromIntegral recvAmount :: BtcAmount) == fromIntegral (sum resRecvdAmounts) -checkSendRecvStateMatch :: (ArbChannelPair, [BitcoinAmount]) -> Bool-checkSendRecvStateMatch (ArbChannelPair sendChan recvChan _ _ _, _) =-    getChannelState sendChan == getChannelState recvChan+alwaysOneOutput :: ChannelPairResult -> TestM Bool+alwaysOneOutput cpr = not . null . HT.txOut <$> mkSettleTx cpr -checkRecvSendAmount :: (ArbChannelPair, [BitcoinAmount]) -> Bool-checkRecvSendAmount (ArbChannelPair _ _ amountSent amountRecvd _, _) =-    amountSent == amountRecvd+checkSendRecvStateMatch :: ChannelPairResult -> TestM Bool+checkSendRecvStateMatch ChannelPairResult{..} =+    return $ getChanState resSendChan == getChanState resRecvChan -testPaymentSession ::-    ((ArbChannelPair, [BitcoinAmount]) -> Bool)+checkRecvSendAmount :: ChannelPairResult -> TestM Bool+checkRecvSendAmount ChannelPairResult{..} =+    return $ if sum resSentAmounts == sum resRecvdAmounts then+        True else error $ show (resSentAmounts, resRecvdAmounts)++testPaymentSessionM ::+    (ChannelPairResult -> TestM Bool)     -> ArbChannelPair-    -> [BitcoinAmount]-    -> Bool-testPaymentSession testFunc arbChanPair paymentAmountList =-    testFunc (runChanPair arbChanPair paymentAmountList)+    -> [BtcAmount]+    -> Property+testPaymentSessionM testFunc arbChanPair payLst =+    monadic runTestM $+        run (runChanPair arbChanPair payLst) >>= run . testFunc >>= assert -runChanPair :: ArbChannelPair -> [BitcoinAmount] -> (ArbChannelPair, [BitcoinAmount])-runChanPair chanPair paymentAmountList =-    (foldl doPayment chanPair paymentAmountList, paymentAmountList) +-- 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 json = JSON.encode fp-              decodedObj = JSON.decode json+        where decodedObj = JSON.decode $ JSON.encode fp               checkEquals serDeserVal =                 if serDeserVal /= fp then                         error ("Ser/deser mismatch.\nOriginal: " ++ show fp ++ "\nCopy: " ++ show decodedObj)