{-# LANGUAGE TemplateHaskell #-}

module BtcLsp.Psbt.PsbtOpener
  ( openChannelPsbt,
    OpenChannelPsbtResult (..),
    OpenUpdateEvt (..),
  )
where

import BtcLsp.Import
import qualified BtcLsp.Math.OnChain as Math
import BtcLsp.Psbt.Utils
  ( finalizePsbt,
    fundPsbtReq,
    lockUtxos,
    openChannelReq,
    psbtFinalizeReq,
    psbtVerifyReq,
    releaseUtxosLocks,
    releaseUtxosPsbtLocks,
    shimCancelReq,
    unspendUtxoLookup,
  )
import qualified Data.Map as M
import qualified LndClient as Lnd
import qualified LndClient.Data.ChannelPoint as Lnd
import qualified LndClient.Data.FinalizePsbt as FNP
import qualified LndClient.Data.FundPsbt as FP
import qualified LndClient.Data.ListUnspent as LU
import qualified LndClient.Data.OpenChannel as Lnd
import qualified LndClient.Data.OutPoint as OP
import qualified LndClient.RPC.Katip as Lnd
import qualified UnliftIO.Exception as UE
import qualified UnliftIO.STM as T

sumAmt :: [PsbtUtxo] -> MSat
sumAmt :: [PsbtUtxo] -> MSat
sumAmt [PsbtUtxo]
utxos = [MSat] -> Element [MSat]
forall t. (Container t, Num (Element t)) => t -> Element t
sum ([MSat] -> Element [MSat]) -> [MSat] -> Element [MSat]
forall a b. (a -> b) -> a -> b
$ PsbtUtxo -> MSat
getAmt (PsbtUtxo -> MSat) -> [PsbtUtxo] -> [MSat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PsbtUtxo]
utxos

autoSelectUtxos :: Env m => OnChainAddress 'Fund -> MSat -> ExceptT Failure m FP.FundPsbtResponse
autoSelectUtxos :: forall (m :: * -> *).
Env m =>
OnChainAddress 'Fund -> MSat -> ExceptT Failure m FundPsbtResponse
autoSelectUtxos OnChainAddress 'Fund
addr MSat
amt = (LndEnv -> FundPsbtRequest -> m (Either LndError FundPsbtResponse))
-> ((FundPsbtRequest -> m (Either LndError FundPsbtResponse))
    -> m (Either LndError FundPsbtResponse))
-> ExceptT Failure m FundPsbtResponse
forall (m :: * -> *) a b.
Env m =>
(LndEnv -> a)
-> (a -> m (Either LndError b)) -> ExceptT Failure m b
withLndT LndEnv -> FundPsbtRequest -> m (Either LndError FundPsbtResponse)
forall (m :: * -> *).
(KatipContext m, MonadUnliftIO m) =>
LndEnv -> FundPsbtRequest -> m (Either LndError FundPsbtResponse)
Lnd.fundPsbt ((FundPsbtRequest -> m (Either LndError FundPsbtResponse))
-> FundPsbtRequest -> m (Either LndError FundPsbtResponse)
forall a b. (a -> b) -> a -> b
$ FundPsbtRequest
req)
  where
    req :: FundPsbtRequest
req = [OutPoint] -> Map Text MSat -> FundPsbtRequest
fundPsbtReq [] ([(Text, MSat)] -> Map Text MSat
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(OnChainAddress 'Fund -> Text
forall (mrel :: MoneyRelation). OnChainAddress mrel -> Text
unOnChainAddress OnChainAddress 'Fund
addr, MSat
amt)])

utxoLeaseToPsbtUtxo :: Map OP.OutPoint LU.Utxo -> FP.UtxoLease -> Maybe PsbtUtxo
utxoLeaseToPsbtUtxo :: Map OutPoint Utxo -> UtxoLease -> Maybe PsbtUtxo
utxoLeaseToPsbtUtxo Map OutPoint Utxo
l UtxoLease
ul = MSat -> PsbtUtxo
psbtUtxo (MSat -> PsbtUtxo) -> (Utxo -> MSat) -> Utxo -> PsbtUtxo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utxo -> MSat
LU.amountSat (Utxo -> PsbtUtxo) -> Maybe Utxo -> Maybe PsbtUtxo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OutPoint -> Map OutPoint Utxo -> Maybe Utxo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup OutPoint
op Map OutPoint Utxo
l
  where
    op :: OutPoint
op = UtxoLease -> OutPoint
FP.outpoint UtxoLease
ul
    psbtUtxo :: MSat -> PsbtUtxo
psbtUtxo MSat
amt =
      PsbtUtxo :: OutPoint -> MSat -> Maybe UtxoLockId -> PsbtUtxo
PsbtUtxo
        { getAmt :: MSat
getAmt = MSat
amt,
          getLockId :: Maybe UtxoLockId
getLockId = UtxoLockId -> Maybe UtxoLockId
forall a. a -> Maybe a
Just (UtxoLockId -> Maybe UtxoLockId)
-> (ByteString -> UtxoLockId) -> ByteString -> Maybe UtxoLockId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> UtxoLockId
UtxoLockId (ByteString -> Maybe UtxoLockId) -> ByteString -> Maybe UtxoLockId
forall a b. (a -> b) -> a -> b
$ UtxoLease -> ByteString
FP.id UtxoLease
ul,
          getOutPoint :: OutPoint
getOutPoint = OutPoint
op
        }

mapLeaseUtxosToPsbtUtxo :: Env m => [FP.UtxoLease] -> ExceptT Failure m [PsbtUtxo]
mapLeaseUtxosToPsbtUtxo :: forall (m :: * -> *).
Env m =>
[UtxoLease] -> ExceptT Failure m [PsbtUtxo]
mapLeaseUtxosToPsbtUtxo [UtxoLease]
lockedUtxos = do
  [UtxoLease] -> ExceptT Failure m ()
forall (m :: * -> *). Env m => [UtxoLease] -> ExceptT Failure m ()
releaseUtxosLocks [UtxoLease]
lockedUtxos
  Map OutPoint Utxo
l <- ExceptT Failure m (Map OutPoint Utxo)
forall (m :: * -> *).
Env m =>
ExceptT Failure m (Map OutPoint Utxo)
unspendUtxoLookup
  [UtxoLease]
newLockedUtxos <- [OutPoint] -> ExceptT Failure m [UtxoLease]
forall (m :: * -> *).
Env m =>
[OutPoint] -> ExceptT Failure m [UtxoLease]
lockUtxos (UtxoLease -> OutPoint
FP.outpoint (UtxoLease -> OutPoint) -> [UtxoLease] -> [OutPoint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [UtxoLease]
lockedUtxos)
  case [Maybe PsbtUtxo] -> Maybe [PsbtUtxo]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Maybe PsbtUtxo] -> Maybe [PsbtUtxo])
-> [Maybe PsbtUtxo] -> Maybe [PsbtUtxo]
forall a b. (a -> b) -> a -> b
$ Map OutPoint Utxo -> UtxoLease -> Maybe PsbtUtxo
utxoLeaseToPsbtUtxo Map OutPoint Utxo
l (UtxoLease -> Maybe PsbtUtxo) -> [UtxoLease] -> [Maybe PsbtUtxo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [UtxoLease]
newLockedUtxos of
    Just [PsbtUtxo]
us -> [PsbtUtxo] -> ExceptT Failure m [PsbtUtxo]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [PsbtUtxo]
us
    Maybe [PsbtUtxo]
Nothing -> do
      $(logTM) Severity
DebugS
        (LogStr -> ExceptT Failure m ())
-> (Text -> LogStr) -> Text -> ExceptT Failure m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr
        (Text -> ExceptT Failure m ()) -> Text -> ExceptT Failure m ()
forall a b. (a -> b) -> a -> b
$ Text
"Cannot find utxo in utxos:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [UtxoLease] -> Text
forall a. Out a => a -> Text
inspect [UtxoLease]
lockedUtxos Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" lookupMap: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Map OutPoint Utxo -> Text
forall a. Out a => a -> Text
inspect Map OutPoint Utxo
l
      Failure -> ExceptT Failure m [PsbtUtxo]
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE
        (Failure -> ExceptT Failure m [PsbtUtxo])
-> (FailureInternal -> Failure)
-> FailureInternal
-> ExceptT Failure m [PsbtUtxo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FailureInternal -> Failure
FailureInt
        (FailureInternal -> ExceptT Failure m [PsbtUtxo])
-> FailureInternal -> ExceptT Failure m [PsbtUtxo]
forall a b. (a -> b) -> a -> b
$ Text -> FailureInternal
FailurePrivate Text
"Cannot find utxo in unspent list"

fundChanPsbt ::
  (Env m) =>
  [PsbtUtxo] ->
  OnChainAddress 'Fund ->
  OnChainAddress 'Gain ->
  Money 'Lsp 'OnChain 'Gain ->
  ExceptT Failure m Lnd.Psbt
fundChanPsbt :: forall (m :: * -> *).
Env m =>
[PsbtUtxo]
-> OnChainAddress 'Fund
-> OnChainAddress 'Gain
-> Money 'Lsp 'OnChain 'Gain
-> ExceptT Failure m Psbt
fundChanPsbt [PsbtUtxo]
userUtxos OnChainAddress 'Fund
chanFundAddr OnChainAddress 'Gain
changeAddr Money 'Lsp 'OnChain 'Gain
lspFee = do
  let userFundingAmt :: MSat
userFundingAmt = [PsbtUtxo] -> MSat
sumAmt [PsbtUtxo]
userUtxos MSat -> MSat -> MSat
forall a. Num a => a -> a -> a
- Money 'Lsp 'OnChain 'Gain -> MSat
coerce Money 'Lsp 'OnChain 'Gain
lspFee

  $(logTM) Severity
DebugS (LogStr -> ExceptT Failure m ()) -> LogStr -> ExceptT Failure m ()
forall a b. (a -> b) -> a -> b
$
    Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr (Text -> LogStr) -> Text -> LogStr
forall a b. (a -> b) -> a -> b
$
      Text
"UserAmt:"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MSat -> Text
forall a. Out a => a -> Text
inspect ([PsbtUtxo] -> MSat
sumAmt [PsbtUtxo]
userUtxos)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" LspFee:"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Money 'Lsp 'OnChain 'Gain -> Text
forall a. Out a => a -> Text
inspect Money 'Lsp 'OnChain 'Gain
lspFee

  FundPsbtResponse
lspFunded <- OnChainAddress 'Fund -> MSat -> ExceptT Failure m FundPsbtResponse
forall (m :: * -> *).
Env m =>
OnChainAddress 'Fund -> MSat -> ExceptT Failure m FundPsbtResponse
autoSelectUtxos (OnChainAddress 'Fund -> OnChainAddress 'Fund
coerce OnChainAddress 'Fund
chanFundAddr) MSat
userFundingAmt
  [PsbtUtxo]
lspUtxos <- [UtxoLease] -> ExceptT Failure m [PsbtUtxo]
forall (m :: * -> *).
Env m =>
[UtxoLease] -> ExceptT Failure m [PsbtUtxo]
mapLeaseUtxosToPsbtUtxo ([UtxoLease] -> ExceptT Failure m [PsbtUtxo])
-> [UtxoLease] -> ExceptT Failure m [PsbtUtxo]
forall a b. (a -> b) -> a -> b
$ FundPsbtResponse -> [UtxoLease]
FP.lockedUtxos FundPsbtResponse
lspFunded
  let selectedInputsAmt :: MSat
selectedInputsAmt = [PsbtUtxo] -> MSat
sumAmt [PsbtUtxo]
lspUtxos
  $(logTM) Severity
DebugS (LogStr -> ExceptT Failure m ()) -> LogStr -> ExceptT Failure m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr (Text -> LogStr) -> Text -> LogStr
forall a b. (a -> b) -> a -> b
$ Text
"Coins sum by lsp" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MSat -> Text
forall a. Out a => a -> Text
inspect MSat
selectedInputsAmt
  let allInputs :: [OutPoint]
allInputs = PsbtUtxo -> OutPoint
getOutPoint (PsbtUtxo -> OutPoint) -> [PsbtUtxo] -> [OutPoint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([PsbtUtxo]
userUtxos [PsbtUtxo] -> [PsbtUtxo] -> [PsbtUtxo]
forall a. Semigroup a => a -> a -> a
<> [PsbtUtxo]
lspUtxos)
  Natural
numInps <-
    Text -> Int -> ExceptT Failure m Natural
forall source target (m :: * -> *).
(Show source, Typeable source, Typeable target,
 TryFrom source target, Monad m, 'False ~ (source == target)) =>
Text -> source -> ExceptT Failure m target
tryFromT Text
"Psbt funding inputs length" ([OutPoint] -> Int
forall t. Container t => t -> Int
length [OutPoint]
allInputs)
  MSat
estFee <-
    Text
-> Either (TryFromException Natural MSat) MSat
-> ExceptT Failure m MSat
forall source target (m :: * -> *).
(Show source, Typeable source, Typeable target, Monad m) =>
Text
-> Either (TryFromException source target) target
-> ExceptT Failure m target
tryFailureT Text
"Psbt funding fee estimator" (Either (TryFromException Natural MSat) MSat
 -> ExceptT Failure m MSat)
-> Either (TryFromException Natural MSat) MSat
-> ExceptT Failure m MSat
forall a b. (a -> b) -> a -> b
$
      InQty
-> OutQty
-> SatPerVbyte
-> Either (TryFromException Natural MSat) MSat
Math.trxEstFee (Natural -> InQty
Math.InQty Natural
numInps) (Natural -> OutQty
Math.OutQty Natural
2) SatPerVbyte
Math.minFeeRate
  --
  -- TODO: find exact additional cost of open trx
  --
  let fee :: MSat
fee = MSat
estFee MSat -> MSat -> MSat
forall a. Num a => a -> a -> a
+ Word64 -> MSat
MSat Word64
50000
  $(logTM) Severity
DebugS (LogStr -> ExceptT Failure m ()) -> LogStr -> ExceptT Failure m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr (Text -> LogStr) -> Text -> LogStr
forall a b. (a -> b) -> a -> b
$ Text
"Est fee:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MSat -> Text
forall a. Out a => a -> Text
inspect MSat
fee
  let changeAmt :: MSat
changeAmt = MSat
selectedInputsAmt MSat -> MSat -> MSat
forall a. Num a => a -> a -> a
- MSat
userFundingAmt MSat -> MSat -> MSat
forall a. Num a => a -> a -> a
+ Money 'Lsp 'OnChain 'Gain -> MSat
coerce Money 'Lsp 'OnChain 'Gain
lspFee MSat -> MSat -> MSat
forall a. Num a => a -> a -> a
- MSat
fee
  let outputs :: [(Text, MSat)]
outputs =
        if MSat
changeAmt MSat -> MSat -> Bool
forall a. Ord a => a -> a -> Bool
> MSat
Math.trxDustLimit
          then
            [ (OnChainAddress 'Fund -> Text
forall (mrel :: MoneyRelation). OnChainAddress mrel -> Text
unOnChainAddress OnChainAddress 'Fund
chanFundAddr, MSat
userFundingAmt MSat -> MSat -> MSat
forall a. Num a => a -> a -> a
* MSat
2),
              (OnChainAddress 'Gain -> Text
forall (mrel :: MoneyRelation). OnChainAddress mrel -> Text
unOnChainAddress OnChainAddress 'Gain
changeAddr, MSat
changeAmt)
            ]
          else
            [ (OnChainAddress 'Fund -> Text
forall (mrel :: MoneyRelation). OnChainAddress mrel -> Text
unOnChainAddress OnChainAddress 'Fund
chanFundAddr, MSat
userFundingAmt MSat -> MSat -> MSat
forall a. Num a => a -> a -> a
* MSat
2 MSat -> MSat -> MSat
forall a. Num a => a -> a -> a
+ MSat
changeAmt)
            ]
  let req :: FundPsbtRequest
req = [OutPoint] -> Map Text MSat -> FundPsbtRequest
fundPsbtReq [OutPoint]
allInputs ([(Text, MSat)] -> Map Text MSat
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Text, MSat)]
outputs)
  [PsbtUtxo] -> ExceptT Failure m ()
forall (m :: * -> *). Env m => [PsbtUtxo] -> ExceptT Failure m ()
releaseUtxosPsbtLocks ([PsbtUtxo]
userUtxos [PsbtUtxo] -> [PsbtUtxo] -> [PsbtUtxo]
forall a. Semigroup a => a -> a -> a
<> [PsbtUtxo]
lspUtxos)
  FundPsbtResponse
psbt <- (LndEnv -> FundPsbtRequest -> m (Either LndError FundPsbtResponse))
-> ((FundPsbtRequest -> m (Either LndError FundPsbtResponse))
    -> m (Either LndError FundPsbtResponse))
-> ExceptT Failure m FundPsbtResponse
forall (m :: * -> *) a b.
Env m =>
(LndEnv -> a)
-> (a -> m (Either LndError b)) -> ExceptT Failure m b
withLndT LndEnv -> FundPsbtRequest -> m (Either LndError FundPsbtResponse)
forall (m :: * -> *).
(KatipContext m, MonadUnliftIO m) =>
LndEnv -> FundPsbtRequest -> m (Either LndError FundPsbtResponse)
Lnd.fundPsbt ((FundPsbtRequest -> m (Either LndError FundPsbtResponse))
-> FundPsbtRequest -> m (Either LndError FundPsbtResponse)
forall a b. (a -> b) -> a -> b
$ FundPsbtRequest
req)
  Psbt -> ExceptT Failure m Psbt
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Psbt -> ExceptT Failure m Psbt) -> Psbt -> ExceptT Failure m Psbt
forall a b. (a -> b) -> a -> b
$ ByteString -> Psbt
Lnd.Psbt (ByteString -> Psbt) -> ByteString -> Psbt
forall a b. (a -> b) -> a -> b
$ FundPsbtResponse -> ByteString
FP.fundedPsbt FundPsbtResponse
psbt

data OpenUpdateEvt = LndUpdate Lnd.OpenStatusUpdate | LndSubFail deriving stock ((forall x. OpenUpdateEvt -> Rep OpenUpdateEvt x)
-> (forall x. Rep OpenUpdateEvt x -> OpenUpdateEvt)
-> Generic OpenUpdateEvt
forall x. Rep OpenUpdateEvt x -> OpenUpdateEvt
forall x. OpenUpdateEvt -> Rep OpenUpdateEvt x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep OpenUpdateEvt x -> OpenUpdateEvt
$cfrom :: forall x. OpenUpdateEvt -> Rep OpenUpdateEvt x
Generic)

instance Out OpenUpdateEvt

data OpenChannelPsbtResult = OpenChannelPsbtResult
  { OpenChannelPsbtResult -> TChan OpenUpdateEvt
tchan :: TChan OpenUpdateEvt,
    OpenChannelPsbtResult -> Async (Either Failure ChannelPoint)
fundAsync :: Async (Either Failure Lnd.ChannelPoint)
  }

openChannelPsbt ::
  Env m =>
  [PsbtUtxo] ->
  NodePubKey ->
  OnChainAddress 'Gain ->
  Money 'Lsp 'OnChain 'Gain ->
  Privacy ->
  ExceptT Failure m OpenChannelPsbtResult
openChannelPsbt :: forall (m :: * -> *).
Env m =>
[PsbtUtxo]
-> NodePubKey
-> OnChainAddress 'Gain
-> Money 'Lsp 'OnChain 'Gain
-> Privacy
-> ExceptT Failure m OpenChannelPsbtResult
openChannelPsbt [PsbtUtxo]
utxos NodePubKey
toPubKey OnChainAddress 'Gain
changeAddress Money 'Lsp 'OnChain 'Gain
lspFee Privacy
private = do
  TChan OpenUpdateEvt
chan <- m (TChan OpenUpdateEvt) -> ExceptT Failure m (TChan OpenUpdateEvt)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (TChan OpenUpdateEvt)
forall (m :: * -> *) a. MonadIO m => m (TChan a)
T.newTChanIO
  PendingChannelId
pcid <- ExceptT Failure m PendingChannelId
forall (m :: * -> *). MonadIO m => m PendingChannelId
Lnd.newPendingChanId
  let openChannelRequest :: OpenChannelRequest
openChannelRequest =
        PendingChannelId
-> NodePubKey
-> Money 'Lsp 'Ln 'Gain
-> Money 'Usr 'Ln 'Gain
-> Privacy
-> OpenChannelRequest
openChannelReq PendingChannelId
pcid NodePubKey
toPubKey (MSat -> Money 'Lsp 'Ln 'Gain
coerce (MSat
2 MSat -> MSat -> MSat
forall a. Num a => a -> a -> a
* MSat
amt)) (MSat -> Money 'Usr 'Ln 'Gain
coerce MSat
amt) Privacy
private
  let subUpdates :: OpenStatusUpdate -> IO ()
subUpdates OpenStatusUpdate
u = IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ())
-> (OpenUpdateEvt -> IO ()) -> OpenUpdateEvt -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
T.atomically (STM () -> IO ())
-> (OpenUpdateEvt -> STM ()) -> OpenUpdateEvt -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TChan OpenUpdateEvt -> OpenUpdateEvt -> STM ()
forall a. TChan a -> a -> STM ()
T.writeTChan TChan OpenUpdateEvt
chan (OpenUpdateEvt -> IO ()) -> OpenUpdateEvt -> IO ()
forall a b. (a -> b) -> a -> b
$ OpenStatusUpdate -> OpenUpdateEvt
LndUpdate OpenStatusUpdate
u
  Either SomeException (Async ())
res <- m (Either SomeException (Async ()))
-> ExceptT Failure m (Either SomeException (Async ()))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either SomeException (Async ()))
 -> ExceptT Failure m (Either SomeException (Async ())))
-> (m () -> m (Either SomeException (Async ())))
-> m ()
-> ExceptT Failure m (Either SomeException (Async ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Async ()) -> m (Either SomeException (Async ()))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
UE.tryAny (m (Async ()) -> m (Either SomeException (Async ())))
-> (m () -> m (Async ()))
-> m ()
-> m (Either SomeException (Async ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> m (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
spawnLink (m () -> ExceptT Failure m (Either SomeException (Async ())))
-> m () -> ExceptT Failure m (Either SomeException (Async ()))
forall a b. (a -> b) -> a -> b
$ do
    Either Failure ()
r <- (LndEnv -> OpenChannelRequest -> m (Either LndError ()))
-> ((OpenChannelRequest -> m (Either LndError ()))
    -> m (Either LndError ()))
-> m (Either Failure ())
forall (m :: * -> *) a b.
Env m =>
(LndEnv -> a)
-> (a -> m (Either LndError b)) -> m (Either Failure b)
withLnd ((OpenStatusUpdate -> IO ())
-> LndEnv -> OpenChannelRequest -> m (Either LndError ())
forall (m :: * -> *).
(KatipContext m, MonadUnliftIO m) =>
(OpenStatusUpdate -> IO ())
-> LndEnv -> OpenChannelRequest -> m (Either LndError ())
Lnd.openChannel OpenStatusUpdate -> IO ()
subUpdates) ((OpenChannelRequest -> m (Either LndError ()))
-> OpenChannelRequest -> m (Either LndError ())
forall a b. (a -> b) -> a -> b
$ OpenChannelRequest
openChannelRequest)
    Either Failure () -> (Failure -> m ()) -> m ()
forall (f :: * -> *) l r.
Applicative f =>
Either l r -> (l -> f ()) -> f ()
whenLeft Either Failure ()
r ((Failure -> m ()) -> m ()) -> (Failure -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Failure
e -> do
      $(logTM) Severity
ErrorS (LogStr -> m ()) -> LogStr -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr (Text -> LogStr) -> Text -> LogStr
forall a b. (a -> b) -> a -> b
$ Text
"Open channel failed" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Failure -> Text
forall a. Out a => a -> Text
inspect Failure
e
      m () -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m () -> m ()) -> (OpenUpdateEvt -> m ()) -> OpenUpdateEvt -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
T.atomically (STM () -> m ())
-> (OpenUpdateEvt -> STM ()) -> OpenUpdateEvt -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TChan OpenUpdateEvt -> OpenUpdateEvt -> STM ()
forall a. TChan a -> a -> STM ()
T.writeTChan TChan OpenUpdateEvt
chan (OpenUpdateEvt -> m ()) -> OpenUpdateEvt -> m ()
forall a b. (a -> b) -> a -> b
$ OpenUpdateEvt
LndSubFail
  case Either SomeException (Async ())
res of
    Left SomeException
e -> Failure -> ExceptT Failure m OpenChannelPsbtResult
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Failure -> ExceptT Failure m OpenChannelPsbtResult)
-> (Text -> Failure)
-> Text
-> ExceptT Failure m OpenChannelPsbtResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FailureInternal -> Failure
FailureInt (FailureInternal -> Failure)
-> (Text -> FailureInternal) -> Text -> Failure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FailureInternal
FailurePrivate (Text -> ExceptT Failure m OpenChannelPsbtResult)
-> Text -> ExceptT Failure m OpenChannelPsbtResult
forall a b. (a -> b) -> a -> b
$ SomeException -> Text
forall a. Out a => a -> Text
inspect SomeException
e
    Right Async ()
_ -> do
      Async (Either Failure ChannelPoint)
fundA <- m (Async (Either Failure ChannelPoint))
-> ExceptT Failure m (Async (Either Failure ChannelPoint))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Async (Either Failure ChannelPoint))
 -> ExceptT Failure m (Async (Either Failure ChannelPoint)))
-> (m (Either Failure ChannelPoint)
    -> m (Async (Either Failure ChannelPoint)))
-> m (Either Failure ChannelPoint)
-> ExceptT Failure m (Async (Either Failure ChannelPoint))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Either Failure ChannelPoint)
-> m (Async (Either Failure ChannelPoint))
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
spawnLink (m (Either Failure ChannelPoint)
 -> ExceptT Failure m (Async (Either Failure ChannelPoint)))
-> m (Either Failure ChannelPoint)
-> ExceptT Failure m (Async (Either Failure ChannelPoint))
forall a b. (a -> b) -> a -> b
$ ExceptT Failure m ChannelPoint -> m (Either Failure ChannelPoint)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Failure m ChannelPoint -> m (Either Failure ChannelPoint))
-> ExceptT Failure m ChannelPoint
-> m (Either Failure ChannelPoint)
forall a b. (a -> b) -> a -> b
$ PendingChannelId
-> TChan OpenUpdateEvt -> ExceptT Failure m ChannelPoint
fundStep PendingChannelId
pcid TChan OpenUpdateEvt
chan
      OpenChannelPsbtResult -> ExceptT Failure m OpenChannelPsbtResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OpenChannelPsbtResult -> ExceptT Failure m OpenChannelPsbtResult)
-> OpenChannelPsbtResult -> ExceptT Failure m OpenChannelPsbtResult
forall a b. (a -> b) -> a -> b
$ TChan OpenUpdateEvt
-> Async (Either Failure ChannelPoint) -> OpenChannelPsbtResult
OpenChannelPsbtResult TChan OpenUpdateEvt
chan Async (Either Failure ChannelPoint)
fundA
  where
    amt :: MSat
amt = [PsbtUtxo] -> MSat
sumAmt [PsbtUtxo]
utxos MSat -> MSat -> MSat
forall a. Num a => a -> a -> a
- Money 'Lsp 'OnChain 'Gain -> MSat
coerce Money 'Lsp 'OnChain 'Gain
lspFee
    fundStep :: PendingChannelId
-> TChan OpenUpdateEvt -> ExceptT Failure m ChannelPoint
fundStep PendingChannelId
pcid TChan OpenUpdateEvt
chan = do
      OpenUpdateEvt
upd <- STM OpenUpdateEvt -> ExceptT Failure m OpenUpdateEvt
forall (m :: * -> *) a. MonadIO m => STM a -> m a
T.atomically (STM OpenUpdateEvt -> ExceptT Failure m OpenUpdateEvt)
-> STM OpenUpdateEvt -> ExceptT Failure m OpenUpdateEvt
forall a b. (a -> b) -> a -> b
$ TChan OpenUpdateEvt -> STM OpenUpdateEvt
forall a. TChan a -> STM a
T.readTChan TChan OpenUpdateEvt
chan
      $(logTM) Severity
DebugS (LogStr -> ExceptT Failure m ()) -> LogStr -> ExceptT Failure m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr (Text -> LogStr) -> Text -> LogStr
forall a b. (a -> b) -> a -> b
$ Text
"Got chan status update" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> OpenUpdateEvt -> Text
forall a. Out a => a -> Text
inspect OpenUpdateEvt
upd
      case OpenUpdateEvt
upd of
        LndUpdate (Lnd.OpenStatusUpdate ByteString
_ (Just (Lnd.OpenStatusUpdatePsbtFund (Lnd.ReadyForPsbtFunding Text
faddr MSat
famt Psbt
_)))) -> do
          $(logTM) Severity
DebugS (LogStr -> ExceptT Failure m ()) -> LogStr -> ExceptT Failure m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr (Text -> LogStr) -> Text -> LogStr
forall a b. (a -> b) -> a -> b
$ Text
"Chan ready for funding at addr:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Out a => a -> Text
inspect Text
faddr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" with amt:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MSat -> Text
forall a. Out a => a -> Text
inspect MSat
famt
          Psbt
psbt' <- [PsbtUtxo]
-> OnChainAddress 'Fund
-> OnChainAddress 'Gain
-> Money 'Lsp 'OnChain 'Gain
-> ExceptT Failure m Psbt
forall (m :: * -> *).
Env m =>
[PsbtUtxo]
-> OnChainAddress 'Fund
-> OnChainAddress 'Gain
-> Money 'Lsp 'OnChain 'Gain
-> ExceptT Failure m Psbt
fundChanPsbt [PsbtUtxo]
utxos (Text -> OnChainAddress 'Fund
forall (mrel :: MoneyRelation). Text -> OnChainAddress mrel
unsafeNewOnChainAddress Text
faddr) (OnChainAddress 'Gain -> OnChainAddress 'Gain
coerce OnChainAddress 'Gain
changeAddress) Money 'Lsp 'OnChain 'Gain
lspFee
          ExceptT Failure m () -> ExceptT Failure m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT Failure m () -> ExceptT Failure m ())
-> ExceptT Failure m () -> ExceptT Failure m ()
forall a b. (a -> b) -> a -> b
$ (LndEnv -> FundingStateStepRequest -> m (Either LndError ()))
-> ((FundingStateStepRequest -> m (Either LndError ()))
    -> m (Either LndError ()))
-> ExceptT Failure m ()
forall (m :: * -> *) a b.
Env m =>
(LndEnv -> a)
-> (a -> m (Either LndError b)) -> ExceptT Failure m b
withLndT LndEnv -> FundingStateStepRequest -> m (Either LndError ())
forall (m :: * -> *).
(KatipContext m, MonadUnliftIO m) =>
LndEnv -> FundingStateStepRequest -> m (Either LndError ())
Lnd.fundingStateStep ((FundingStateStepRequest -> m (Either LndError ()))
-> FundingStateStepRequest -> m (Either LndError ())
forall a b. (a -> b) -> a -> b
$ PendingChannelId -> Psbt -> FundingStateStepRequest
psbtVerifyReq PendingChannelId
pcid Psbt
psbt')
          FinalizePsbtResponse
sPsbtResp <- Psbt -> ExceptT Failure m FinalizePsbtResponse
forall (m :: * -> *).
Env m =>
Psbt -> ExceptT Failure m FinalizePsbtResponse
finalizePsbt Psbt
psbt'
          $(logTM) Severity
DebugS (LogStr -> ExceptT Failure m ()) -> LogStr -> ExceptT Failure m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr (Text -> LogStr) -> Text -> LogStr
forall a b. (a -> b) -> a -> b
$ Text
"Used psbt for funding:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FinalizePsbtResponse -> Text
forall a. Out a => a -> Text
inspect FinalizePsbtResponse
sPsbtResp
          ExceptT Failure m () -> ExceptT Failure m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT Failure m () -> ExceptT Failure m ())
-> ExceptT Failure m () -> ExceptT Failure m ()
forall a b. (a -> b) -> a -> b
$ (LndEnv -> FundingStateStepRequest -> m (Either LndError ()))
-> ((FundingStateStepRequest -> m (Either LndError ()))
    -> m (Either LndError ()))
-> ExceptT Failure m ()
forall (m :: * -> *) a b.
Env m =>
(LndEnv -> a)
-> (a -> m (Either LndError b)) -> ExceptT Failure m b
withLndT LndEnv -> FundingStateStepRequest -> m (Either LndError ())
forall (m :: * -> *).
(KatipContext m, MonadUnliftIO m) =>
LndEnv -> FundingStateStepRequest -> m (Either LndError ())
Lnd.fundingStateStep ((FundingStateStepRequest -> m (Either LndError ()))
-> FundingStateStepRequest -> m (Either LndError ())
forall a b. (a -> b) -> a -> b
$ PendingChannelId -> Psbt -> FundingStateStepRequest
psbtFinalizeReq PendingChannelId
pcid (ByteString -> Psbt
Lnd.Psbt (ByteString -> Psbt) -> ByteString -> Psbt
forall a b. (a -> b) -> a -> b
$ FinalizePsbtResponse -> ByteString
FNP.signedPsbt FinalizePsbtResponse
sPsbtResp))
          PendingChannelId
-> TChan OpenUpdateEvt -> ExceptT Failure m ChannelPoint
fundStep PendingChannelId
pcid TChan OpenUpdateEvt
chan
        LndUpdate (Lnd.OpenStatusUpdate ByteString
_ (Just (Lnd.OpenStatusUpdateChanPending PendingUpdate 'Funding
p))) -> do
          $(logTM) Severity
DebugS (LogStr -> ExceptT Failure m ()) -> LogStr -> ExceptT Failure m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr (Text -> LogStr) -> Text -> LogStr
forall a b. (a -> b) -> a -> b
$ Text
"Chan is pending... mining..." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PendingUpdate 'Funding -> Text
forall a. Out a => a -> Text
inspect PendingUpdate 'Funding
p
          PendingChannelId
-> TChan OpenUpdateEvt -> ExceptT Failure m ChannelPoint
fundStep PendingChannelId
pcid TChan OpenUpdateEvt
chan
        LndUpdate (Lnd.OpenStatusUpdate ByteString
_ (Just (Lnd.OpenStatusUpdateChanOpen (Lnd.ChannelOpenUpdate ChannelPoint
cp)))) -> do
          $(logTM) Severity
DebugS (LogStr -> ExceptT Failure m ()) -> LogStr -> ExceptT Failure m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr (Text -> LogStr) -> Text -> LogStr
forall a b. (a -> b) -> a -> b
$ Text
"Chan is open" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ChannelPoint -> Text
forall a. Out a => a -> Text
inspect ChannelPoint
cp
          ChannelPoint -> ExceptT Failure m ChannelPoint
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChannelPoint
cp
        OpenUpdateEvt
LndSubFail -> do
          ExceptT Failure m () -> ExceptT Failure m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT Failure m () -> ExceptT Failure m ())
-> ExceptT Failure m () -> ExceptT Failure m ()
forall a b. (a -> b) -> a -> b
$ (LndEnv -> FundingStateStepRequest -> m (Either LndError ()))
-> ((FundingStateStepRequest -> m (Either LndError ()))
    -> m (Either LndError ()))
-> ExceptT Failure m ()
forall (m :: * -> *) a b.
Env m =>
(LndEnv -> a)
-> (a -> m (Either LndError b)) -> ExceptT Failure m b
withLndT LndEnv -> FundingStateStepRequest -> m (Either LndError ())
forall (m :: * -> *).
(KatipContext m, MonadUnliftIO m) =>
LndEnv -> FundingStateStepRequest -> m (Either LndError ())
Lnd.fundingStateStep ((FundingStateStepRequest -> m (Either LndError ()))
-> FundingStateStepRequest -> m (Either LndError ())
forall a b. (a -> b) -> a -> b
$ PendingChannelId -> FundingStateStepRequest
shimCancelReq PendingChannelId
pcid)
          ExceptT Failure m [UtxoLease] -> ExceptT Failure m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT Failure m [UtxoLease] -> ExceptT Failure m ())
-> ExceptT Failure m [UtxoLease] -> ExceptT Failure m ()
forall a b. (a -> b) -> a -> b
$ [OutPoint] -> ExceptT Failure m [UtxoLease]
forall (m :: * -> *).
Env m =>
[OutPoint] -> ExceptT Failure m [UtxoLease]
lockUtxos (PsbtUtxo -> OutPoint
getOutPoint (PsbtUtxo -> OutPoint) -> [PsbtUtxo] -> [OutPoint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PsbtUtxo]
utxos)
          Failure -> ExceptT Failure m ChannelPoint
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (FailureInternal -> Failure
FailureInt (FailureInternal -> Failure) -> FailureInternal -> Failure
forall a b. (a -> b) -> a -> b
$ Text -> FailureInternal
FailurePrivate Text
"Lnd subscription failed. Trying to cancel psbt flow. Its ok if cancel fails")
        OpenUpdateEvt
_ -> Failure -> ExceptT Failure m ChannelPoint
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (FailureInternal -> Failure
FailureInt (FailureInternal -> Failure) -> FailureInternal -> Failure
forall a b. (a -> b) -> a -> b
$ Text -> FailureInternal
FailurePrivate Text
"Unexpected update")