module PaymentChannel.Client
( validFundingInfo
, channelWithInitialPayment
, createPayment
, createPaymentCapped
, createClosingPayment
, getRefundBitcoinTx
, RefundTx
)
where
import PaymentChannel.Server (getSignedSettlementTx)
import PaymentChannel.Internal.Payment
import PaymentChannel.Internal.Receiver.Util
import Bitcoin.Util (calcTxSize)
import PaymentChannel.Internal.Refund (RefundTx, mkRefundTx)
import PaymentChannel.Types
import Data.Functor.Identity (Identity(..))
import Control.Exception (Exception, throw)
import qualified RBPCP.Types as RBPCP
import qualified Network.Haskoin.Crypto as HC
import qualified Network.Haskoin.Transaction as HT
data ChannelCreationError
= FundingError CreationError
| InsufficientFundingValue BtcAmount
| BadServerFundingAddress (ExpectFail HC.Address)
instance Exception ChannelCreationError
instance Show ChannelCreationError where
show (FundingError e) = unwords
[ "Funding error:"
, show e
]
show (InsufficientFundingValue val) = unwords
[ "Insufficient funding value to pay server-defined 'open price' of"
, show val
]
show (BadServerFundingAddress expec) = unwords
[ "Disagreement on channel funding address.", show expec ]
validFundingInfo
:: SendPubKey
-> LockTimeDate
-> RBPCP.FundingInfo
-> Either ChannelCreationError ChanParams
validFundingInfo sendPK lockTime RBPCP.FundingInfo{..} =
if correctAddress /= serversAddress
then Left $ BadServerFundingAddress $ serversAddress `FoundButExpected` correctAddress
else Right chanParams
where
serversAddress = fundingInfoFundingAddressCopy
getServerKey (RBPCP.Server pk) = pk
correctAddress = getP2SHFundingAddress chanParams
chanParams = ChanParams
sendPK
(MkRecvPubKey $ getServerKey fundingInfoServerPubkey)
lockTime
channelWithInitialPayment
:: HC.PrvKeyC
-> LockTimeDate
-> (HT.Tx, RBPCP.Vout)
-> RBPCP.FundingInfo
-> Either ChannelCreationError (ClientPayChanI BtcSig, SignedPayment)
channelWithInitialPayment prvKey expTime fundingTxVout fi@RBPCP.FundingInfo{..} =
let serverConf = fromFundingInfo fi
mkPayChanState sp = MkPayChanState sp (fromInitialPayment sp) serverConf
mkClientChan sp = (MkClientPayChan (mkPayChanState sp) prvKey, sp)
openPrice = fromIntegral fundingInfoOpenPrice
clientPK = MkSendPubKey $ HC.derivePubKey prvKey
in do
cp <- validFundingInfo clientPK expTime fi
unsignedPay <- fmapL FundingError $ runConfM serverConf $
mkUnsignedPayment cp fundingTxVout (getP2SHFundingAddress cp)
initialPay <- fmapL (const $ InsufficientFundingValue openPrice) $
createPaymentInternal unsignedPay serverConf prvKey (openPrice :: BtcAmount)
Right $ mkClientChan initialPay
createPayment ::
ClientPayChan
-> BtcAmount
-> Either BtcError (ClientPayChan, SignedPayment)
createPayment cpc@MkClientPayChan{..} val = do
payment <- createPaymentInternal (pcsPayment spcState) (pcsSettings spcState) spcPrvKey val
Right (updateClientState cpc payment, payment)
updateClientState :: ClientPayChan -> SignedPayment -> ClientPayChan
updateClientState cpc@MkClientPayChan{..} payment =
cpc { spcState = updatePcs payment }
where
updatePcs p = spcState { pcsPayment = p }
createPaymentCapped ::
ClientPayChan
-> Capped BtcAmount
-> (ClientPayChan, SignedPayment, BtcAmount)
createPaymentCapped = createPaymentCappedInternal
createPaymentCappedInternal ::
ClientPayChanI sd
-> Capped BtcAmount
-> (ClientPayChan, SignedPayment, BtcAmount)
createPaymentCappedInternal cpc@MkClientPayChan{..} cappedVal =
let
newPayment = failOnBug $ createPaymentInternal
(pcsPayment spcState) (pcsSettings spcState) spcPrvKey cappedVal
failOnBug (Right newPay) = newPay
failOnBug (Left e) = error $ "BUG: createPaymentCapped: capped amount math fail: " ++ show e
realVal = clientChangeVal (pcsPayment spcState) - clientChangeVal newPayment
updatePcs p = spcState { pcsPayment = p }
updateState p = cpc { spcState = updatePcs p }
in
(updateState newPayment, newPayment, realVal)
createPaymentInternal ::
PaymentValueSpec value
=> Payment sd
-> ServerSettings
-> HC.PrvKeyC
-> value
-> Either BtcError SignedPayment
createPaymentInternal oldPayment servSettings prvKey payVal =
let
actualPayVal = paymentValue (clientChangeVal oldPayment) servSettings payVal
paymentE = runConfM servSettings $ createPaymentOfValue
prvKey (clearSig oldPayment) actualPayVal
checkSignErr e = if isKeyError e then throw $ Bug e else e
in
fmapL checkSignErr paymentE
createClosingPayment
:: (ToChangeOutFee fee, HasFee fee )
=> ClientPayChanI BtcSig
-> HC.Address
-> fee
-> (ClientPayChanI BtcSig, SignedPayment, BtcAmount)
createClosingPayment clientState changeAddress fee =
createPaymentCapped newState (Capped $ absoluteFee 0 (dummySettleTxSize newState actualAmount) fee)
where
(newState, _, actualAmount) = createPaymentCappedInternal
newChangeAddrState (Capped $ absoluteFee 0 (dummySettleTxSize fakeSigNewAddrState (0 :: BtcAmount)) fee)
dummySettleTxSize cpc' fee' = calcTxSize $ dummyClientSettleTx cpc' fee'
newChangeAddrState = _setClientChangeAddr clientState changeAddress
fakeSigNewAddrState = mapSigData _invalidBtcSig newChangeAddrState
handleSettleRet = either (error . ("createClosingPayment. woops: " ++) . show) id
dummyClientSettleTx :: ToChangeOutFee txFee => ClientPayChan -> txFee -> HT.Tx
dummyClientSettleTx cpc txFee = toHaskoinTx . handleSettleRet . runDummy $ getSignedSettlementTx
(dummyFromClientState cpc) (mkChangeFee txFee, DropDust)
getRefundBitcoinTx
:: ( Monad m, ToChangeOutFee fee )
=> ClientPayChan
-> HC.Address
-> fee
-> m (Either BtcError RefundTx)
getRefundBitcoinTx =
mkRefundTx
{-# SPECIALIZE createPaymentInternal :: Payment BtcSig -> ServerSettings -> HC.PrvKeyC -> BtcAmount -> Either BtcError SignedPayment #-}
{-# SPECIALIZE createPaymentInternal :: Payment BtcSig -> ServerSettings -> HC.PrvKeyC -> Capped BtcAmount -> Either BtcError SignedPayment #-}