module PaymentChannel.Server
(
hasMinimumDuration
, channelFromInitialPayment
, acceptPayment
, acceptClosingPayment
, closedGetSettlementTxSimple
, closedGetSettlementTxDerive
, getSignedSettlementTx
, SettleTx
) where
import PaymentChannel.Internal.Payment
import PaymentChannel.RBPCP.Parse
import PaymentChannel.Internal.Receiver.Util
import PaymentChannel.Internal.Receiver.Open (initialServerState)
import PaymentChannel.Internal.Settlement
import PaymentChannel.Types
import PaymentChannel.Internal.Error
import qualified Network.Haskoin.Crypto as HC
import qualified Network.Haskoin.Transaction as HT
import Control.Monad.Trans.Either
hasMinimumDuration ::
( HasLockTimeDate lockTime, MonadTime m )
=> ServerSettings
-> lockTime
-> m (Either OpenError ())
hasMinimumDuration ServerSettings{..} lt = do
hasMinDuration <- isLocked (toSeconds $ serverConfSettlePeriod + serverConfMinDuration) lt
return $ if hasMinDuration
then Right ()
else Left $ InsufficientDuration serverConfMinDuration
channelFromInitialPayment ::
MonadTime m
=> ServerSettings
-> HT.Tx
-> PaymentData
-> m (Either PayChanError ServerPayChan)
channelFromInitialPayment cfg@ServerSettings{..} tx paymentData = runEitherT $ do
initialState <- hoistEither $ fmapL OpenError $ initialServerState cfg tx paymentData
hoistEither . checkOpenPrice
=<< hoistEither
=<< acceptPaymentInternal paymentData initialState
where
checkOpenPrice (state,val) =
if val /= serverConfOpenPrice
then Left $ OpenError $ IncorrectInitialPaymentValue $ val `FoundButExpected` serverConfOpenPrice
else Right state
acceptPayment :: MonadTime m =>
PaymentData
-> ServerPayChanI kd
-> m (Either PayChanError (ServerPayChanI kd, BtcAmount))
acceptPayment = acceptPaymentInternal
acceptPaymentInternal ::
( MonadTime m
, StateSignature sd
) =>
PaymentData
-> ServerPayChanG kd sd
-> m (Either PayChanError (ServerPayChanI kd, BtcAmount))
acceptPaymentInternal paymentData rpc =
either (return . Left) (acceptPaymentIgnoreStatus paymentData) (checkChannelStatus rpc)
acceptClosingPayment :: MonadTime m =>
PaymentData
-> ServerPayChanI kd
-> m (Either PayChanError (ClosedServerChanI kd))
acceptClosingPayment paymentData oldState =
fmap handleResult <$> acceptClosingPaymentInternal paymentData oldState
where
mkNewStatus newState = ChannelClosed $ getPayment newState
getPayment = pcsPayment . rpcState
handleResult (newState, _) = MkClosedServerChan
(setChannelStatus (mkNewStatus newState) oldState)
(getPayment newState)
acceptPaymentIgnoreStatus ::
( MonadTime m
, StateSignature sd
) =>
PaymentData
-> ServerPayChanG kd sd
-> m (Either PayChanError (ServerPayChanG kd BtcSig, BtcAmount))
acceptPaymentIgnoreStatus paymentData rpc@MkServerPayChan{..} =
either (return . Left) checkPayment (getPayment paymentData)
where
serverConf = pcsSettings rpcState
getPayment pd = fmapL RBPCPError $ runConfM serverConf $ fromPaymentData (getFundingAmount rpc) pd
mkReturnValue p val = (updateMetadata $ updState rpc p, val)
checkPayment p = do
valRecvdE <- paymentValueIncrease rpcState p
return $ mkReturnValue p <$> valRecvdE
acceptClosingPaymentInternal ::
MonadTime m
=> PaymentData
-> ServerPayChanI kd
-> m (Either PayChanError (ServerPayChanI kd, BtcAmount))
acceptClosingPaymentInternal paymentData oldState =
acceptPaymentIgnoreStatus paymentData newChangeAddrState
where
newChangeAddrState = _setClientChangeAddr oldState (paymentDataChangeAddress paymentData)
closedGetSettlementTxSimple ::
PrvKeyC
-> ClosedServerChanI a
-> HC.Address
-> SatoshisPerByte
-> DustPolicy
-> Either ReceiverError SettleTx
closedGetSettlementTxSimple prvKey csc@MkClosedServerChan{..} recvAdr minFee dp = do
(settleState,txFee) <- closedSettleInternalAcceptPay csc
runSimple prvKey $ getSignedSettlementTx settleState (mkChangeOut txFee)
where
mkChangeOut fee = ChangeOut recvAdr (MaximumFee $ MaxFee (fee,minFee)) dp
closedGetSettlementTxDerive ::
DeriveChangeOut SignedPayment (TxFee,DustPolicy) signKey ChanParams
=> ClosedServerChanI a
-> SatoshisPerByte
-> DustPolicy
-> SignM signKey (Either ReceiverError SettleTx)
closedGetSettlementTxDerive csc@MkClosedServerChan{..} minFee dp = do
let getSettleTx (settleState,txFee) = getSignedSettlementTx settleState (MaximumFee $ MaxFee (txFee,minFee), dp)
either (return . Left) getSettleTx (closedSettleInternalAcceptPay csc)
closedSettleInternalAcceptPay
:: ClosedServerChanI t
-> Either ReceiverError (ServerPayChanI t, BtcAmount)
closedSettleInternalAcceptPay MkClosedServerChan{..} =
fmapL BadClosedServerChan resE
where
resE = resultFromThePast $
acceptClosingPaymentInternal (toPaymentData cscClosingPayment) cscState
{-# SPECIALIZE acceptPaymentInternal :: MonadTime m => PaymentData -> ServerPayChan -> m (Either PayChanError (ServerPayChan, BtcAmount)) #-}
{-# SPECIALIZE acceptPaymentInternal :: MonadTime m => PaymentData -> ServerPayChanX -> m (Either PayChanError (ServerPayChanX, BtcAmount)) #-}