{-# LANGUAGE TemplateHaskell #-}

module BtcLsp.Thread.LnChanWatcher
  ( applyPoll,
    applySub,
  )
where

import BtcLsp.Import
import qualified BtcLsp.Storage.Model.LnChan as LnChan
import qualified Data.Set as Set
import qualified LndClient.Data.Channel as Lnd hiding (outputIndex)
import qualified LndClient.Data.ChannelBackup as Bak
import qualified LndClient.Data.ChannelPoint as Lnd
import LndClient.Data.ClosedChannels (ClosedChannelsRequest (..))
import LndClient.Data.ListChannels
import qualified LndClient.RPC.Silent as LndSilent

syncChannelList :: (Env m) => m ()
syncChannelList :: forall (m :: * -> *). Env m => m ()
syncChannelList = do
  Either Failure ()
res <-
    ExceptT Failure m () -> m (Either Failure ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Failure m () -> m (Either Failure ()))
-> ExceptT Failure m () -> m (Either Failure ())
forall a b. (a -> b) -> a -> b
$ do
      [Channel]
openedChans <-
        (LndEnv -> ListChannelsRequest -> m (Either LndError [Channel]))
-> ((ListChannelsRequest -> m (Either LndError [Channel]))
    -> m (Either LndError [Channel]))
-> ExceptT Failure m [Channel]
forall (m :: * -> *) a b.
Env m =>
(LndEnv -> a)
-> (a -> m (Either LndError b)) -> ExceptT Failure m b
withLndT
          LndEnv -> ListChannelsRequest -> m (Either LndError [Channel])
forall (m :: * -> *).
MonadUnliftIO m =>
LndEnv -> ListChannelsRequest -> m (Either LndError [Channel])
LndSilent.listChannels
          ((ListChannelsRequest -> m (Either LndError [Channel]))
-> ListChannelsRequest -> m (Either LndError [Channel])
forall a b. (a -> b) -> a -> b
$ Bool
-> Bool -> Bool -> Bool -> Maybe NodePubKey -> ListChannelsRequest
ListChannelsRequest Bool
False Bool
False Bool
False Bool
False Maybe NodePubKey
forall a. Maybe a
Nothing)
      --
      -- TODO : get list of channels which are opened
      -- according database status, but not in openedChans
      -- list according lnd. Need to check are they closed
      -- and update status.
      --
      [(Channel, Maybe SingleChanBackupBlob)]
openedChansBak <-
        (Channel
 -> ExceptT Failure m (Channel, Maybe SingleChanBackupBlob))
-> [Channel]
-> ExceptT Failure m [(Channel, Maybe SingleChanBackupBlob)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
          ( \Channel
ch -> do
              let cp :: ChannelPoint
cp =
                    Channel -> ChannelPoint
Lnd.channelPoint Channel
ch
              let getBakT :: ExceptT Failure m (Maybe SingleChanBackupBlob)
getBakT =
                    SingleChanBackupBlob -> Maybe SingleChanBackupBlob
forall a. a -> Maybe a
Just (SingleChanBackupBlob -> Maybe SingleChanBackupBlob)
-> (ChannelBackup -> SingleChanBackupBlob)
-> ChannelBackup
-> Maybe SingleChanBackupBlob
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChannelBackup -> SingleChanBackupBlob
Bak.chanBackup
                      (ChannelBackup -> Maybe SingleChanBackupBlob)
-> ExceptT Failure m ChannelBackup
-> ExceptT Failure m (Maybe SingleChanBackupBlob)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LndEnv -> ChannelPoint -> m (Either LndError ChannelBackup))
-> ((ChannelPoint -> m (Either LndError ChannelBackup))
    -> m (Either LndError ChannelBackup))
-> ExceptT Failure m ChannelBackup
forall (m :: * -> *) a b.
Env m =>
(LndEnv -> a)
-> (a -> m (Either LndError b)) -> ExceptT Failure m b
withLndT
                        LndEnv -> ChannelPoint -> m (Either LndError ChannelBackup)
forall (m :: * -> *).
MonadUnliftIO m =>
LndEnv -> ChannelPoint -> m (Either LndError ChannelBackup)
LndSilent.exportChannelBackup
                        ((ChannelPoint -> m (Either LndError ChannelBackup))
-> ChannelPoint -> m (Either LndError ChannelBackup)
forall a b. (a -> b) -> a -> b
$ Channel -> ChannelPoint
Lnd.channelPoint Channel
ch)
              Maybe LnChan
mCh <-
                m (Maybe LnChan) -> ExceptT Failure m (Maybe LnChan)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
                  (m (Maybe LnChan) -> ExceptT Failure m (Maybe LnChan))
-> (Vout 'Funding -> m (Maybe LnChan))
-> Vout 'Funding
-> ExceptT Failure m (Maybe LnChan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entity LnChan -> LnChan
forall record. Entity record -> record
entityVal (Entity LnChan -> LnChan)
-> m (Maybe (Entity LnChan)) -> m (Maybe LnChan)
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<<$>>)
                  (m (Maybe (Entity LnChan)) -> m (Maybe LnChan))
-> (Vout 'Funding -> m (Maybe (Entity LnChan)))
-> Vout 'Funding
-> m (Maybe LnChan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT SqlBackend m (Maybe (Entity LnChan))
-> m (Maybe (Entity LnChan))
forall (m :: * -> *) a. Storage m => ReaderT SqlBackend m a -> m a
runSql
                  (ReaderT SqlBackend m (Maybe (Entity LnChan))
 -> m (Maybe (Entity LnChan)))
-> (Vout 'Funding -> ReaderT SqlBackend m (Maybe (Entity LnChan)))
-> Vout 'Funding
-> m (Maybe (Entity LnChan))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxId 'Funding
-> Vout 'Funding -> ReaderT SqlBackend m (Maybe (Entity LnChan))
forall (m :: * -> *).
Storage m =>
TxId 'Funding
-> Vout 'Funding -> ReaderT SqlBackend m (Maybe (Entity LnChan))
LnChan.getByChannelPointSql (ChannelPoint -> TxId 'Funding
Lnd.fundingTxId ChannelPoint
cp)
                  (Vout 'Funding -> ExceptT Failure m (Maybe LnChan))
-> Vout 'Funding -> ExceptT Failure m (Maybe LnChan)
forall a b. (a -> b) -> a -> b
$ ChannelPoint -> Vout 'Funding
Lnd.outputIndex ChannelPoint
cp
              Maybe SingleChanBackupBlob
mBak <-
                case Maybe LnChan
mCh of
                  Maybe LnChan
Nothing -> ExceptT Failure m (Maybe SingleChanBackupBlob)
getBakT
                  Just (LnChan {lnChanBak :: LnChan -> Maybe SingleChanBackupBlob
lnChanBak = Maybe SingleChanBackupBlob
Nothing}) -> ExceptT Failure m (Maybe SingleChanBackupBlob)
getBakT
                  Just {} -> Maybe SingleChanBackupBlob
-> ExceptT Failure m (Maybe SingleChanBackupBlob)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SingleChanBackupBlob
forall a. Maybe a
Nothing
              (Channel, Maybe SingleChanBackupBlob)
-> ExceptT Failure m (Channel, Maybe SingleChanBackupBlob)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                ( Channel
ch,
                  Maybe SingleChanBackupBlob
mBak
                )
          )
          [Channel]
openedChans
      [ChannelCloseSummary]
closedChans <-
        (LndEnv
 -> ClosedChannelsRequest
 -> m (Either LndError [ChannelCloseSummary]))
-> ((ClosedChannelsRequest
     -> m (Either LndError [ChannelCloseSummary]))
    -> m (Either LndError [ChannelCloseSummary]))
-> ExceptT Failure m [ChannelCloseSummary]
forall (m :: * -> *) a b.
Env m =>
(LndEnv -> a)
-> (a -> m (Either LndError b)) -> ExceptT Failure m b
withLndT
          LndEnv
-> ClosedChannelsRequest
-> m (Either LndError [ChannelCloseSummary])
forall (m :: * -> *).
MonadUnliftIO m =>
LndEnv
-> ClosedChannelsRequest
-> m (Either LndError [ChannelCloseSummary])
LndSilent.closedChannels
          ( (ClosedChannelsRequest
 -> m (Either LndError [ChannelCloseSummary]))
-> ClosedChannelsRequest
-> m (Either LndError [ChannelCloseSummary])
forall a b. (a -> b) -> a -> b
$
              Bool
-> Bool -> Bool -> Bool -> Bool -> Bool -> ClosedChannelsRequest
ClosedChannelsRequest
                Bool
False
                Bool
False
                Bool
False
                Bool
False
                Bool
False
                Bool
False
          )
      Set ChannelPoint
nonSwapSet <- m (Set ChannelPoint) -> ExceptT Failure m (Set ChannelPoint)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Set ChannelPoint) -> ExceptT Failure m (Set ChannelPoint))
-> (ReaderT SqlBackend m (Set ChannelPoint)
    -> m (Set ChannelPoint))
-> ReaderT SqlBackend m (Set ChannelPoint)
-> ExceptT Failure m (Set ChannelPoint)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT SqlBackend m (Set ChannelPoint) -> m (Set ChannelPoint)
forall (m :: * -> *) a. Storage m => ReaderT SqlBackend m a -> m a
runSql (ReaderT SqlBackend m (Set ChannelPoint)
 -> ExceptT Failure m (Set ChannelPoint))
-> ReaderT SqlBackend m (Set ChannelPoint)
-> ExceptT Failure m (Set ChannelPoint)
forall a b. (a -> b) -> a -> b
$ do
        ReaderT SqlBackend m [Entity LnChan] -> ReaderT SqlBackend m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT SqlBackend m [Entity LnChan] -> ReaderT SqlBackend m ())
-> ReaderT SqlBackend m [Entity LnChan] -> ReaderT SqlBackend m ()
forall a b. (a -> b) -> a -> b
$ [(Channel, Maybe SingleChanBackupBlob)]
-> ReaderT SqlBackend m [Entity LnChan]
forall (m :: * -> *).
MonadIO m =>
[(Channel, Maybe SingleChanBackupBlob)]
-> ReaderT SqlBackend m [Entity LnChan]
LnChan.persistOpenedChannelsSql [(Channel, Maybe SingleChanBackupBlob)]
openedChansBak
        ReaderT SqlBackend m [Entity LnChan] -> ReaderT SqlBackend m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT SqlBackend m [Entity LnChan] -> ReaderT SqlBackend m ())
-> ReaderT SqlBackend m [Entity LnChan] -> ReaderT SqlBackend m ()
forall a b. (a -> b) -> a -> b
$ [ChannelCloseSummary] -> ReaderT SqlBackend m [Entity LnChan]
forall (m :: * -> *).
MonadIO m =>
[ChannelCloseSummary] -> ReaderT SqlBackend m [Entity LnChan]
LnChan.persistClosedChannelsSql [ChannelCloseSummary]
closedChans
        [Entity LnChan]
nonSwapList <- ReaderT SqlBackend m [Entity LnChan]
forall (m :: * -> *).
Storage m =>
ReaderT SqlBackend m [Entity LnChan]
LnChan.getActiveNonSwapSql
        Set ChannelPoint -> ReaderT SqlBackend m (Set ChannelPoint)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set ChannelPoint -> ReaderT SqlBackend m (Set ChannelPoint))
-> ([ChannelPoint] -> Set ChannelPoint)
-> [ChannelPoint]
-> ReaderT SqlBackend m (Set ChannelPoint)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ChannelPoint] -> Set ChannelPoint
forall l. (FromList l, FromListC l) => [ListElement l] -> l
fromList ([ChannelPoint] -> ReaderT SqlBackend m (Set ChannelPoint))
-> [ChannelPoint] -> ReaderT SqlBackend m (Set ChannelPoint)
forall a b. (a -> b) -> a -> b
$
          ( \(Entity {entityVal :: forall record. Entity record -> record
entityVal = LnChan
x}) ->
              TxId 'Funding -> Vout 'Funding -> ChannelPoint
Lnd.ChannelPoint
                (LnChan -> TxId 'Funding
lnChanFundingTxId LnChan
x)
                (LnChan -> Vout 'Funding
lnChanFundingVout LnChan
x)
          )
            (Entity LnChan -> ChannelPoint)
-> [Entity LnChan] -> [ChannelPoint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Entity LnChan]
nonSwapList
      let nonSwapChans :: [Channel]
nonSwapChans =
            (Channel -> Bool) -> [Channel] -> [Channel]
forall a. (a -> Bool) -> [a] -> [a]
filter
              ( \Channel
x ->
                  ( Channel -> ChannelPoint
Lnd.channelPoint Channel
x
                      ChannelPoint -> Set ChannelPoint -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ChannelPoint
nonSwapSet
                  )
                    Bool -> Bool -> Bool
&& Bool -> Bool
not (Channel -> Bool
Lnd.prv Channel
x)
                    Bool -> Bool -> Bool
&& Channel -> Bool
Lnd.active Channel
x
              )
              [Channel]
openedChans
      m () -> ExceptT Failure m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
        (m () -> ExceptT Failure m ())
-> ([MSat] -> m ()) -> [MSat] -> ExceptT Failure m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Liquidity 'Outgoing -> m ()
forall (m :: * -> *). Env m => Liquidity 'Outgoing -> m ()
monitorTotalExtOutgoingLiquidity
        (Liquidity 'Outgoing -> m ())
-> ([MSat] -> Liquidity 'Outgoing) -> [MSat] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MSat -> Liquidity 'Outgoing
forall (dir :: Direction). MSat -> Liquidity dir
Liquidity
        (MSat -> Liquidity 'Outgoing)
-> ([MSat] -> MSat) -> [MSat] -> Liquidity 'Outgoing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MSat] -> MSat
forall t. (Container t, Num (Element t)) => t -> Element t
sum
        ([MSat] -> ExceptT Failure m ()) -> [MSat] -> ExceptT Failure m ()
forall a b. (a -> b) -> a -> b
$ Channel -> MSat
Lnd.localBalance (Channel -> MSat) -> [Channel] -> [MSat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Channel]
nonSwapChans
      m () -> ExceptT Failure m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
        (m () -> ExceptT Failure m ())
-> ([MSat] -> m ()) -> [MSat] -> ExceptT Failure m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Liquidity 'Incoming -> m ()
forall (m :: * -> *). Env m => Liquidity 'Incoming -> m ()
monitorTotalExtIncomingLiquidity
        (Liquidity 'Incoming -> m ())
-> ([MSat] -> Liquidity 'Incoming) -> [MSat] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MSat -> Liquidity 'Incoming
forall (dir :: Direction). MSat -> Liquidity dir
Liquidity
        (MSat -> Liquidity 'Incoming)
-> ([MSat] -> MSat) -> [MSat] -> Liquidity 'Incoming
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MSat] -> MSat
forall t. (Container t, Num (Element t)) => t -> Element t
sum
        ([MSat] -> ExceptT Failure m ()) -> [MSat] -> ExceptT Failure m ()
forall a b. (a -> b) -> a -> b
$ Channel -> MSat
Lnd.remoteBalance (Channel -> MSat) -> [Channel] -> [MSat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Channel]
nonSwapChans
  Either Failure () -> (Failure -> m ()) -> m ()
forall (f :: * -> *) l r.
Applicative f =>
Either l r -> (l -> f ()) -> f ()
whenLeft Either Failure ()
res ((Failure -> m ()) -> m ()) -> (Failure -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$
    $(logTM) Severity
ErrorS (LogStr -> m ()) -> (Failure -> LogStr) -> Failure -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr
      (Text -> LogStr) -> (Failure -> Text) -> Failure -> LogStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"SyncChannelList failure " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)
      (Text -> Text) -> (Failure -> Text) -> Failure -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Failure -> Text
forall a. Out a => a -> Text
inspect

applyPoll :: (Env m) => m ()
applyPoll :: forall (m :: * -> *). Env m => m ()
applyPoll =
  m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    m ()
forall (m :: * -> *). Env m => m ()
syncChannelList
      m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
forall (m :: * -> *). MonadIO m => m ()
sleep300ms

applySub :: (Env m) => m ()
applySub :: forall (m :: * -> *). Env m => m ()
applySub =
  m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    LndEnv
lnd <- m LndEnv
forall (m :: * -> *). Env m => m LndEnv
getLspLndEnv
    ((forall a. m a -> IO a) -> IO ()) -> m ()
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO ()) -> m ())
-> ((forall a. m a -> IO a) -> IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run -> do
      IO (Either LndError ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either LndError ()) -> IO ())
-> IO (Either LndError ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
        (ChannelEventUpdate -> IO ()) -> LndEnv -> IO (Either LndError ())
forall (m :: * -> *).
MonadUnliftIO m =>
(ChannelEventUpdate -> IO ()) -> LndEnv -> m (Either LndError ())
LndSilent.subscribeChannelEvents
          ( IO (Entity LnChan) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
              (IO (Entity LnChan) -> IO ())
-> (ChannelEventUpdate -> IO (Entity LnChan))
-> ChannelEventUpdate
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Entity LnChan) -> IO (Entity LnChan)
forall a. m a -> IO a
run
              (m (Entity LnChan) -> IO (Entity LnChan))
-> (ChannelEventUpdate -> m (Entity LnChan))
-> ChannelEventUpdate
-> IO (Entity LnChan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT SqlBackend m (Entity LnChan) -> m (Entity LnChan)
forall (m :: * -> *) a. Storage m => ReaderT SqlBackend m a -> m a
runSql
              (ReaderT SqlBackend m (Entity LnChan) -> m (Entity LnChan))
-> (ChannelEventUpdate -> ReaderT SqlBackend m (Entity LnChan))
-> ChannelEventUpdate
-> m (Entity LnChan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChannelEventUpdate -> ReaderT SqlBackend m (Entity LnChan)
forall (m :: * -> *).
KatipContext m =>
ChannelEventUpdate -> ReaderT SqlBackend m (Entity LnChan)
LnChan.persistChannelUpdateSql
          )
          LndEnv
lnd
    m ()
forall (m :: * -> *). MonadIO m => m ()
sleep300ms