{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}

module BtcLsp.Thread.BlockScanner
  ( apply,
    scan,
    Utxo (..),
    extractRelatedUtxoFromBlock,
    mapVout,
  )
where

import BtcLsp.Data.Orphan ()
import qualified BtcLsp.Data.Smart as Smart
import BtcLsp.Import
import qualified BtcLsp.Import.Psql as Psql
import qualified BtcLsp.Math.OnChain as Math
import BtcLsp.Psbt.Utils (lockUtxo)
import qualified BtcLsp.Storage.Model.Block as Block
import qualified BtcLsp.Storage.Model.SwapIntoLn as SwapIntoLn
import qualified BtcLsp.Storage.Model.SwapUtxo as SwapUtxo
import qualified Data.Vector as V
import LndClient (txIdParser)
import qualified LndClient.Data.FundPsbt as FP
import qualified LndClient.Data.OutPoint as OP
import qualified LndClient.RPC.Katip as Lnd
import qualified Network.Bitcoin as Btc
import qualified Network.Bitcoin.BlockChain as Btc
import qualified Network.Bitcoin.Types as Btc
import qualified Universum

apply :: (Env m) => m ()
apply :: forall (m :: * -> *). Env m => m ()
apply =
  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
    (Failure -> m ())
-> ([Utxo] -> m ()) -> m (Either Failure [Utxo]) -> m ()
forall (m :: * -> *) a c b.
Monad m =>
(a -> m c) -> (b -> m c) -> m (Either a b) -> m c
eitherM
      ( $(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
. Failure -> Text
forall a. Out a => a -> Text
inspect
      )
      [Utxo] -> m ()
forall (m :: * -> *). Env m => [Utxo] -> m ()
maybeFunded
      (m (Either Failure [Utxo]) -> m ())
-> (ExceptT Failure m [Utxo] -> m (Either Failure [Utxo]))
-> ExceptT Failure m [Utxo]
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT Failure m [Utxo] -> m (Either Failure [Utxo])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
      (ExceptT Failure m [Utxo] -> m ())
-> ExceptT Failure m [Utxo] -> m ()
forall a b. (a -> b) -> a -> b
$ ExceptT Failure m ()
forall (m :: * -> *). Env m => ExceptT Failure m ()
monitorOnChainLiquidity ExceptT Failure m ()
-> ExceptT Failure m [Utxo] -> ExceptT Failure m [Utxo]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExceptT Failure m [Utxo]
forall (m :: * -> *). Env m => ExceptT Failure m [Utxo]
scan
    m ()
forall (m :: * -> *). MonadIO m => m ()
sleep300ms

maybeFunded :: (Env m) => [Utxo] -> m ()
maybeFunded :: forall (m :: * -> *). Env m => [Utxo] -> m ()
maybeFunded [] =
  () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
maybeFunded [Utxo]
utxos =
  (Element [SwapIntoLnId] -> m ()) -> [SwapIntoLnId] -> m ()
forall t (m :: * -> *) b.
(Container t, Monad m) =>
(Element t -> m b) -> t -> m ()
mapM_ Element [SwapIntoLnId] -> m ()
forall (m :: * -> *). Env m => SwapIntoLnId -> m ()
maybeFundSwap
    ([SwapIntoLnId] -> m ())
-> ([SwapIntoLnId] -> [SwapIntoLnId]) -> [SwapIntoLnId] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SwapIntoLnId] -> [SwapIntoLnId]
forall a. Ord a => [a] -> [a]
nubOrd
    ([SwapIntoLnId] -> m ()) -> [SwapIntoLnId] -> m ()
forall a b. (a -> b) -> a -> b
$ Utxo -> SwapIntoLnId
utxoSwapId (Utxo -> SwapIntoLnId) -> [Utxo] -> [SwapIntoLnId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Utxo]
utxos

maybeFundSwap :: (Env m) => SwapIntoLnId -> m ()
maybeFundSwap :: forall (m :: * -> *). Env m => SwapIntoLnId -> m ()
maybeFundSwap SwapIntoLnId
swapId = do
  Either (Entity SwapIntoLn) ()
res <- ReaderT SqlBackend m (Either (Entity SwapIntoLn) ())
-> m (Either (Entity SwapIntoLn) ())
forall (m :: * -> *) a. Storage m => ReaderT SqlBackend m a -> m a
runSql
    (ReaderT SqlBackend m (Either (Entity SwapIntoLn) ())
 -> m (Either (Entity SwapIntoLn) ()))
-> ((SwapIntoLn -> ReaderT SqlBackend m ())
    -> ReaderT SqlBackend m (Either (Entity SwapIntoLn) ()))
-> (SwapIntoLn -> ReaderT SqlBackend m ())
-> m (Either (Entity SwapIntoLn) ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SwapIntoLnId
-> (SwapStatus -> Bool)
-> (SwapIntoLn -> ReaderT SqlBackend m ())
-> ReaderT SqlBackend m (Either (Entity SwapIntoLn) ())
forall (m :: * -> *) a.
MonadIO m =>
SwapIntoLnId
-> (SwapStatus -> Bool)
-> (SwapIntoLn -> ReaderT SqlBackend m a)
-> ReaderT SqlBackend m (Either (Entity SwapIntoLn) a)
SwapIntoLn.withLockedRowSql
      SwapIntoLnId
swapId
      (Element [SwapStatus] -> [SwapStatus] -> Bool
forall t. (Container t, Eq (Element t)) => Element t -> t -> Bool
`elem` [SwapStatus]
swapStatusChain)
    ((SwapIntoLn -> ReaderT SqlBackend m ())
 -> m (Either (Entity SwapIntoLn) ()))
-> (SwapIntoLn -> ReaderT SqlBackend m ())
-> m (Either (Entity SwapIntoLn) ())
forall a b. (a -> b) -> a -> b
$ \SwapIntoLn
swapVal -> do
      [Entity SwapUtxo]
us <- SwapIntoLnId -> ReaderT SqlBackend m [Entity SwapUtxo]
forall (m :: * -> *).
MonadIO m =>
SwapIntoLnId -> ReaderT SqlBackend m [Entity SwapUtxo]
SwapUtxo.getSpendableUtxosBySwapIdSql SwapIntoLnId
swapId
      let amt :: Element [Money 'Usr 'OnChain 'Fund]
amt = [Money 'Usr 'OnChain 'Fund] -> Element [Money 'Usr 'OnChain 'Fund]
forall t. (Container t, Num (Element t)) => t -> Element t
sum ([Money 'Usr 'OnChain 'Fund]
 -> Element [Money 'Usr 'OnChain 'Fund])
-> [Money 'Usr 'OnChain 'Fund]
-> Element [Money 'Usr 'OnChain 'Fund]
forall a b. (a -> b) -> a -> b
$ SwapUtxo -> Money 'Usr 'OnChain 'Fund
swapUtxoAmount (SwapUtxo -> Money 'Usr 'OnChain 'Fund)
-> (Entity SwapUtxo -> SwapUtxo)
-> Entity SwapUtxo
-> Money 'Usr 'OnChain 'Fund
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity SwapUtxo -> SwapUtxo
forall record. Entity record -> record
entityVal (Entity SwapUtxo -> Money 'Usr 'OnChain 'Fund)
-> [Entity SwapUtxo] -> [Money 'Usr 'OnChain 'Fund]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Entity SwapUtxo]
us
      Maybe SwapCap
mCap <- m (Maybe SwapCap) -> ReaderT SqlBackend m (Maybe SwapCap)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe SwapCap) -> ReaderT SqlBackend m (Maybe SwapCap))
-> m (Maybe SwapCap) -> ReaderT SqlBackend m (Maybe SwapCap)
forall a b. (a -> b) -> a -> b
$ Money 'Usr 'OnChain 'Fund -> m (Maybe SwapCap)
forall (m :: * -> *).
Env m =>
Money 'Usr 'OnChain 'Fund -> m (Maybe SwapCap)
newSwapCapM Element [Money 'Usr 'OnChain 'Fund]
Money 'Usr 'OnChain 'Fund
amt
      $(logTM) Severity
DebugS (LogStr -> ReaderT SqlBackend m ())
-> (Text -> LogStr) -> Text -> ReaderT SqlBackend m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr (Text -> ReaderT SqlBackend m ())
-> Text -> ReaderT SqlBackend m ()
forall a b. (a -> b) -> a -> b
$
        Text -> (SwapCap -> Text) -> Maybe SwapCap -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          ( Text
"Not enough funds for "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SwapIntoLnId -> Text
forall a. Out a => a -> Text
inspect SwapIntoLnId
swapId
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" with amt = "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Money 'Usr 'OnChain 'Fund -> Text
forall a. Out a => a -> Text
inspect Element [Money 'Usr 'OnChain 'Fund]
Money 'Usr 'OnChain 'Fund
amt
          )
          ( \SwapCap
cap ->
              Text
"Marking funded "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SwapIntoLnId -> Text
forall a. Out a => a -> Text
inspect SwapIntoLnId
swapId
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" with amt = "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Money 'Usr 'OnChain 'Fund -> Text
forall a. Out a => a -> Text
inspect Element [Money 'Usr 'OnChain 'Fund]
Money 'Usr 'OnChain 'Fund
amt
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and cap = "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SwapCap -> Text
forall a. Out a => a -> Text
inspect SwapCap
cap
          )
          Maybe SwapCap
mCap
      Maybe SwapCap
-> (SwapCap -> ReaderT SqlBackend m ()) -> ReaderT SqlBackend m ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe SwapCap
mCap ((SwapCap -> ReaderT SqlBackend m ()) -> ReaderT SqlBackend m ())
-> (SwapCap -> ReaderT SqlBackend m ()) -> ReaderT SqlBackend m ()
forall a b. (a -> b) -> a -> b
$ \SwapCap
swapCap -> do
        RowQty
qty <-
          [Key SwapUtxo] -> ReaderT SqlBackend m RowQty
forall (m :: * -> *).
MonadIO m =>
[Key SwapUtxo] -> ReaderT SqlBackend m RowQty
SwapUtxo.updateUnspentChanReserveSql ([Key SwapUtxo] -> ReaderT SqlBackend m RowQty)
-> [Key SwapUtxo] -> ReaderT SqlBackend m RowQty
forall a b. (a -> b) -> a -> b
$
            Entity SwapUtxo -> Key SwapUtxo
forall record. Entity record -> Key record
entityKey (Entity SwapUtxo -> Key SwapUtxo)
-> [Entity SwapUtxo] -> [Key SwapUtxo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Entity SwapUtxo]
us
        if RowQty
qty RowQty -> RowQty -> Bool
forall a. Eq a => a -> a -> Bool
/= Int -> RowQty
forall source target.
(From source target, 'False ~ (source == target)) =>
source -> target
from ([Entity SwapUtxo] -> Int
forall t. Container t => t -> Int
length [Entity SwapUtxo]
us)
          then do
            ReaderT SqlBackend m ()
forall (m :: * -> *). MonadIO m => ReaderT SqlBackend m ()
Psql.transactionUndo
            $(logTM) Severity
ErrorS (LogStr -> ReaderT SqlBackend m ())
-> (Text -> LogStr) -> Text -> ReaderT SqlBackend m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr (Text -> ReaderT SqlBackend m ())
-> Text -> ReaderT SqlBackend m ()
forall a b. (a -> b) -> a -> b
$
              Text
"Funding update "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SwapIntoLn -> Text
forall a. Out a => a -> Text
inspect SwapIntoLn
swapVal
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" failed for UTXOs "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Entity SwapUtxo] -> Text
forall a. Out a => a -> Text
inspect [Entity SwapUtxo]
us
          else
            SwapIntoLnId -> SwapCap -> ReaderT SqlBackend m ()
forall (m :: * -> *).
MonadIO m =>
SwapIntoLnId -> SwapCap -> ReaderT SqlBackend m ()
SwapIntoLn.updateWaitingPeerSql
              SwapIntoLnId
swapId
              SwapCap
swapCap
  Either (Entity SwapIntoLn) ()
-> (Entity SwapIntoLn -> m ()) -> m ()
forall (f :: * -> *) l r.
Applicative f =>
Either l r -> (l -> f ()) -> f ()
whenLeft Either (Entity SwapIntoLn) ()
res ((Entity SwapIntoLn -> m ()) -> m ())
-> (Entity SwapIntoLn -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$
    $(logTM) Severity
WarningS
      (LogStr -> m ())
-> (Entity SwapIntoLn -> LogStr) -> Entity SwapIntoLn -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr
      (Text -> LogStr)
-> (Entity SwapIntoLn -> Text) -> Entity SwapIntoLn -> LogStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"Funding failed due to wrong status " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)
      (Text -> Text)
-> (Entity SwapIntoLn -> Text) -> Entity SwapIntoLn -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity SwapIntoLn -> Text
forall a. Out a => a -> Text
inspect

data Utxo = Utxo
  { Utxo -> MSat
utxoAmt :: MSat,
    Utxo -> Vout 'Funding
utxoVout :: Vout 'Funding,
    Utxo -> TxId 'Funding
utxoTxId :: TxId 'Funding,
    Utxo -> SwapIntoLnId
utxoSwapId :: SwapIntoLnId,
    Utxo -> Maybe UtxoLockId
utxoLockId :: Maybe UtxoLockId
  }
  deriving stock (Int -> Utxo -> ShowS
[Utxo] -> ShowS
Utxo -> String
(Int -> Utxo -> ShowS)
-> (Utxo -> String) -> ([Utxo] -> ShowS) -> Show Utxo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Utxo] -> ShowS
$cshowList :: [Utxo] -> ShowS
show :: Utxo -> String
$cshow :: Utxo -> String
showsPrec :: Int -> Utxo -> ShowS
$cshowsPrec :: Int -> Utxo -> ShowS
Show)

mapVout ::
  ( Env m
  ) =>
  Btc.TransactionID ->
  Btc.TxOut ->
  m (Maybe Utxo)
mapVout :: forall (m :: * -> *).
Env m =>
TransactionID -> TxOut -> m (Maybe Utxo)
mapVout TransactionID
txid (Btc.TxOut BTC
amt Integer
vout (Btc.StandardScriptPubKeyV22 Text
_ Text
_ TxnOutputType
_ Text
addr)) =
  Text -> BTC -> Integer -> TransactionID -> m (Maybe Utxo)
forall (m :: * -> *).
Env m =>
Text -> BTC -> Integer -> TransactionID -> m (Maybe Utxo)
handleAddr Text
addr BTC
amt Integer
vout TransactionID
txid
mapVout TransactionID
txid txout :: TxOut
txout@(Btc.TxOut BTC
amt Integer
vout (Btc.StandardScriptPubKey Text
_ Text
_ Integer
_ TxnOutputType
_ Vector Text
addrsV)) =
  case Vector Text -> [Text]
forall a. Vector a -> [a]
V.toList Vector Text
addrsV of
    [Text
addr] -> Text -> BTC -> Integer -> TransactionID -> m (Maybe Utxo)
forall (m :: * -> *).
Env m =>
Text -> BTC -> Integer -> TransactionID -> m (Maybe Utxo)
handleAddr Text
addr BTC
amt Integer
vout TransactionID
txid
    [Text]
_ -> do
      $(logTM) Severity
ErrorS (LogStr -> m ()) -> (Text -> LogStr) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        Text
"Unsupported address vector in txid = "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TransactionID -> Text
forall a. Out a => a -> Text
inspect TransactionID
txid
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and txout = "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxOut -> Text
forall b a. (Show a, IsString b) => a -> b
Universum.show TxOut
txout
      Maybe Utxo -> m (Maybe Utxo)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Utxo
forall a. Maybe a
Nothing
mapVout TransactionID
_ (Btc.TxOut BTC
_ Integer
_ Btc.NonStandardScriptPubKey {}) =
  Maybe Utxo -> m (Maybe Utxo)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Utxo
forall a. Maybe a
Nothing

handleAddr ::
  ( Env m
  ) =>
  Btc.Address ->
  Btc.BTC ->
  Integer ->
  Btc.TransactionID ->
  m (Maybe Utxo)
handleAddr :: forall (m :: * -> *).
Env m =>
Text -> BTC -> Integer -> TransactionID -> m (Maybe Utxo)
handleAddr Text
addr BTC
amt Integer
vout TransactionID
txid = do
  Maybe (Entity SwapIntoLn)
mswp <- Text -> m (Maybe (Entity SwapIntoLn))
forall (m :: * -> *).
Env m =>
Text -> m (Maybe (Entity SwapIntoLn))
maybeSwap Text
addr
  case Maybe (Entity SwapIntoLn)
mswp of
    Just Entity SwapIntoLn
swp ->
      Either Failure MSat
-> Either
     (TryFromException Integer (Vout 'Funding)) (Vout 'Funding)
-> Either LndError ByteString
-> Entity SwapIntoLn
-> m (Maybe Utxo)
forall (m :: * -> *).
Env m =>
Either Failure MSat
-> Either
     (TryFromException Integer (Vout 'Funding)) (Vout 'Funding)
-> Either LndError ByteString
-> Entity SwapIntoLn
-> m (Maybe Utxo)
newUtxo
        (BTC -> Either Failure MSat
Math.trySatToMsat BTC
amt)
        (Integer
-> Either
     (TryFromException Integer (Vout 'Funding)) (Vout 'Funding)
forall source target.
(TryFrom source target, 'False ~ (source == target)) =>
source -> Either (TryFromException source target) target
tryFrom Integer
vout)
        (Text -> Either LndError ByteString
txIdParser (Text -> Either LndError ByteString)
-> Text -> Either LndError ByteString
forall a b. (a -> b) -> a -> b
$ TransactionID -> Text
Btc.unTransactionID TransactionID
txid)
        Entity SwapIntoLn
swp
    Maybe (Entity SwapIntoLn)
Nothing ->
      Maybe Utxo -> m (Maybe Utxo)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Utxo
forall a. Maybe a
Nothing

newUtxo ::
  ( Env m
  ) =>
  Either Failure MSat ->
  Either (TryFromException Integer (Vout 'Funding)) (Vout 'Funding) ->
  Either LndError ByteString ->
  Entity SwapIntoLn ->
  m (Maybe Utxo)
newUtxo :: forall (m :: * -> *).
Env m =>
Either Failure MSat
-> Either
     (TryFromException Integer (Vout 'Funding)) (Vout 'Funding)
-> Either LndError ByteString
-> Entity SwapIntoLn
-> m (Maybe Utxo)
newUtxo (Right MSat
amt) (Right Vout 'Funding
n) (Right ByteString
txid) Entity SwapIntoLn
swp =
  Maybe Utxo -> m (Maybe Utxo)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Utxo -> m (Maybe Utxo))
-> (Utxo -> Maybe Utxo) -> Utxo -> m (Maybe Utxo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utxo -> Maybe Utxo
forall a. a -> Maybe a
Just (Utxo -> m (Maybe Utxo)) -> Utxo -> m (Maybe Utxo)
forall a b. (a -> b) -> a -> b
$
    MSat
-> Vout 'Funding
-> TxId 'Funding
-> SwapIntoLnId
-> Maybe UtxoLockId
-> Utxo
Utxo MSat
amt Vout 'Funding
n (ByteString -> TxId 'Funding
forall source target.
(From source target, 'False ~ (source == target)) =>
source -> target
from ByteString
txid) (Entity SwapIntoLn -> SwapIntoLnId
forall record. Entity record -> Key record
entityKey Entity SwapIntoLn
swp) Maybe UtxoLockId
forall a. Maybe a
Nothing
newUtxo Either Failure MSat
amt Either (TryFromException Integer (Vout 'Funding)) (Vout 'Funding)
vout Either LndError ByteString
txid Entity SwapIntoLn
swp = do
  $(logTM) Severity
ErrorS (LogStr -> m ()) -> (Text -> LogStr) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
    Text
"TryFrom overflow error amt = "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Either Failure MSat -> Text
forall b a. (Show a, IsString b) => a -> b
Universum.show Either Failure MSat
amt
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" vout = "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Either (TryFromException Integer (Vout 'Funding)) (Vout 'Funding)
-> Text
forall b a. (Show a, IsString b) => a -> b
Universum.show Either (TryFromException Integer (Vout 'Funding)) (Vout 'Funding)
vout
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" txid = "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Either LndError ByteString -> Text
forall a. Out a => a -> Text
inspect Either LndError ByteString
txid
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and swap = "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Entity SwapIntoLn -> Text
forall a. Out a => a -> Text
inspect Entity SwapIntoLn
swp
  Maybe Utxo -> m (Maybe Utxo)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Utxo
forall a. Maybe a
Nothing

extractRelatedUtxoFromBlock ::
  ( Env m
  ) =>
  Btc.BlockVerbose ->
  m [Utxo]
extractRelatedUtxoFromBlock :: forall (m :: * -> *). Env m => BlockVerbose -> m [Utxo]
extractRelatedUtxoFromBlock BlockVerbose
blk =
  (DecodedRawTransaction -> [Utxo] -> m [Utxo])
-> [Utxo] -> Vector DecodedRawTransaction -> m [Utxo]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM DecodedRawTransaction -> [Utxo] -> m [Utxo]
forall {m :: * -> *}.
Env m =>
DecodedRawTransaction -> [Utxo] -> m [Utxo]
foldTrx [] (Vector DecodedRawTransaction -> m [Utxo])
-> Vector DecodedRawTransaction -> m [Utxo]
forall a b. (a -> b) -> a -> b
$
    BlockVerbose -> Vector DecodedRawTransaction
Btc.vSubTransactions BlockVerbose
blk
  where
    foldTrx :: DecodedRawTransaction -> [Utxo] -> m [Utxo]
foldTrx DecodedRawTransaction
trx [Utxo]
acc = do
      [Maybe Utxo]
utxos <-
        (TxOut -> m (Maybe Utxo)) -> [TxOut] -> m [Maybe Utxo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TransactionID -> TxOut -> m (Maybe Utxo)
forall (m :: * -> *).
Env m =>
TransactionID -> TxOut -> m (Maybe Utxo)
mapVout (TransactionID -> TxOut -> m (Maybe Utxo))
-> TransactionID -> TxOut -> m (Maybe Utxo)
forall a b. (a -> b) -> a -> b
$ DecodedRawTransaction -> TransactionID
Btc.decTxId DecodedRawTransaction
trx)
          ([TxOut] -> m [Maybe Utxo])
-> (Vector TxOut -> [TxOut]) -> Vector TxOut -> m [Maybe Utxo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector TxOut -> [TxOut]
forall a. Vector a -> [a]
V.toList
          (Vector TxOut -> m [Maybe Utxo]) -> Vector TxOut -> m [Maybe Utxo]
forall a b. (a -> b) -> a -> b
$ DecodedRawTransaction -> Vector TxOut
Btc.decVout DecodedRawTransaction
trx
      [Utxo] -> m [Utxo]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Utxo] -> m [Utxo]) -> [Utxo] -> m [Utxo]
forall a b. (a -> b) -> a -> b
$
        [Maybe Utxo] -> [Utxo]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Utxo]
utxos [Utxo] -> [Utxo] -> [Utxo]
forall a. Semigroup a => a -> a -> a
<> [Utxo]
acc

persistBlockT ::
  ( Storage m,
    Env m
  ) =>
  Btc.BlockVerbose ->
  [Utxo] ->
  ExceptT Failure m ()
persistBlockT :: forall (m :: * -> *).
(Storage m, Env m) =>
BlockVerbose -> [Utxo] -> ExceptT Failure m ()
persistBlockT BlockVerbose
blk [Utxo]
utxos = do
  BlkHeight
height <-
    Text -> Integer -> ExceptT Failure m BlkHeight
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
"persistBlockT block height" (Integer -> ExceptT Failure m BlkHeight)
-> Integer -> ExceptT Failure m BlkHeight
forall a b. (a -> b) -> a -> b
$
      BlockVerbose -> Integer
Btc.vBlkHeight BlockVerbose
blk
  m () -> ExceptT Failure m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT Failure m ())
-> (ReaderT SqlBackend m () -> m ())
-> ReaderT SqlBackend m ()
-> ExceptT Failure m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT SqlBackend m () -> m ()
forall (m :: * -> *) a. Storage m => ReaderT SqlBackend m a -> m a
runSql (ReaderT SqlBackend m () -> ExceptT Failure m ())
-> ReaderT SqlBackend m () -> ExceptT Failure m ()
forall a b. (a -> b) -> a -> b
$ do
    Key Block
blockId <-
      Entity Block -> Key Block
forall record. Entity record -> Key record
entityKey
        (Entity Block -> Key Block)
-> ReaderT SqlBackend m (Entity Block)
-> ReaderT SqlBackend m (Key Block)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlkHeight -> BlkHash -> ReaderT SqlBackend m (Entity Block)
forall (m :: * -> *).
MonadIO m =>
BlkHeight -> BlkHash -> ReaderT SqlBackend m (Entity Block)
Block.createUpdateConfirmedSql
          BlkHeight
height
          (Text -> BlkHash
forall source target.
(From source target, 'False ~ (source == target)) =>
source -> target
from (Text -> BlkHash) -> Text -> BlkHash
forall a b. (a -> b) -> a -> b
$ BlockVerbose -> Text
Btc.vBlockHash BlockVerbose
blk)
    UTCTime
ct <-
      ReaderT SqlBackend m UTCTime
forall (m :: * -> *). MonadIO m => m UTCTime
getCurrentTime
    Either (Entity Block) ()
res <-
      Key Block
-> (BlkStatus -> Bool)
-> (Block -> ReaderT SqlBackend m ())
-> ReaderT SqlBackend m (Either (Entity Block) ())
forall (m :: * -> *) a.
MonadIO m =>
Key Block
-> (BlkStatus -> Bool)
-> (Block -> ReaderT SqlBackend m a)
-> ReaderT SqlBackend m (Either (Entity Block) a)
Block.withLockedRowSql Key Block
blockId (BlkStatus -> BlkStatus -> Bool
forall a. Eq a => a -> a -> Bool
== BlkStatus
BlkConfirmed)
        ((Block -> ReaderT SqlBackend m ())
 -> ReaderT SqlBackend m (Either (Entity Block) ()))
-> (ReaderT SqlBackend m () -> Block -> ReaderT SqlBackend m ())
-> ReaderT SqlBackend m ()
-> ReaderT SqlBackend m (Either (Entity Block) ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT SqlBackend m () -> Block -> ReaderT SqlBackend m ()
forall a b. a -> b -> a
const
        (ReaderT SqlBackend m ()
 -> ReaderT SqlBackend m (Either (Entity Block) ()))
-> ReaderT SqlBackend m ()
-> ReaderT SqlBackend m (Either (Entity Block) ())
forall a b. (a -> b) -> a -> b
$ do
          [SwapUtxo] -> ReaderT SqlBackend m ()
forall (m :: * -> *).
MonadIO m =>
[SwapUtxo] -> ReaderT SqlBackend m ()
SwapUtxo.createIgnoreManySql ([SwapUtxo] -> ReaderT SqlBackend m ())
-> [SwapUtxo] -> ReaderT SqlBackend m ()
forall a b. (a -> b) -> a -> b
$
            UTCTime -> Key Block -> Utxo -> SwapUtxo
newSwapUtxo UTCTime
ct Key Block
blockId (Utxo -> SwapUtxo) -> [Utxo] -> [SwapUtxo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Utxo]
utxos
          Key Block -> ReaderT SqlBackend m ()
forall (m :: * -> *).
MonadIO m =>
Key Block -> ReaderT SqlBackend m ()
SwapUtxo.updateRefundBlockIdSql Key Block
blockId
    Either (Entity Block) ()
-> (Entity Block -> ReaderT SqlBackend m ())
-> ReaderT SqlBackend m ()
forall (f :: * -> *) l r.
Applicative f =>
Either l r -> (l -> f ()) -> f ()
whenLeft Either (Entity Block) ()
res ((Entity Block -> ReaderT SqlBackend m ())
 -> ReaderT SqlBackend m ())
-> (Entity Block -> ReaderT SqlBackend m ())
-> ReaderT SqlBackend m ()
forall a b. (a -> b) -> a -> b
$
      $(logTM) Severity
ErrorS
        (LogStr -> ReaderT SqlBackend m ())
-> (Entity Block -> LogStr)
-> Entity Block
-> ReaderT SqlBackend m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr
        (Text -> LogStr)
-> (Entity Block -> Text) -> Entity Block -> LogStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"UTXOs are not persisted for the block " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)
        (Text -> Text) -> (Entity Block -> Text) -> Entity Block -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity Block -> Text
forall a. Out a => a -> Text
inspect

newSwapUtxo :: UTCTime -> BlockId -> Utxo -> SwapUtxo
newSwapUtxo :: UTCTime -> Key Block -> Utxo -> SwapUtxo
newSwapUtxo UTCTime
ct Key Block
blkId Utxo
utxo = do
  SwapUtxo :: SwapIntoLnId
-> Key Block
-> TxId 'Funding
-> Vout 'Funding
-> Money 'Usr 'OnChain 'Fund
-> SwapUtxoStatus
-> Maybe (Key Block)
-> Maybe (TxId 'Funding)
-> Maybe UtxoLockId
-> UTCTime
-> UTCTime
-> SwapUtxo
SwapUtxo
    { swapUtxoSwapIntoLnId :: SwapIntoLnId
swapUtxoSwapIntoLnId = Utxo -> SwapIntoLnId
utxoSwapId Utxo
utxo,
      swapUtxoBlockId :: Key Block
swapUtxoBlockId = Key Block
blkId,
      swapUtxoTxid :: TxId 'Funding
swapUtxoTxid = Utxo -> TxId 'Funding
utxoTxId Utxo
utxo,
      swapUtxoVout :: Vout 'Funding
swapUtxoVout = Utxo -> Vout 'Funding
utxoVout Utxo
utxo,
      swapUtxoAmount :: Money 'Usr 'OnChain 'Fund
swapUtxoAmount = MSat -> Money 'Usr 'OnChain 'Fund
forall source target.
(From source target, 'False ~ (source == target)) =>
source -> target
from MSat
amt,
      swapUtxoStatus :: SwapUtxoStatus
swapUtxoStatus =
        if MSat
amt MSat -> MSat -> Bool
forall a. Ord a => a -> a -> Bool
>= MSat
Math.trxDustLimit
          then SwapUtxoStatus
SwapUtxoUnspent
          else SwapUtxoStatus
SwapUtxoUnspentDust,
      swapUtxoRefundTxId :: Maybe (TxId 'Funding)
swapUtxoRefundTxId = Maybe (TxId 'Funding)
forall a. Maybe a
Nothing,
      swapUtxoRefundBlockId :: Maybe (Key Block)
swapUtxoRefundBlockId = Maybe (Key Block)
forall a. Maybe a
Nothing,
      swapUtxoLockId :: Maybe UtxoLockId
swapUtxoLockId = Utxo -> Maybe UtxoLockId
utxoLockId Utxo
utxo,
      swapUtxoInsertedAt :: UTCTime
swapUtxoInsertedAt = UTCTime
ct,
      swapUtxoUpdatedAt :: UTCTime
swapUtxoUpdatedAt = UTCTime
ct
    }
  where
    amt :: MSat
amt = Utxo -> MSat
utxoAmt Utxo
utxo

scan ::
  ( Env m
  ) =>
  ExceptT Failure m [Utxo]
scan :: forall (m :: * -> *). Env m => ExceptT Failure m [Utxo]
scan = do
  Maybe (Entity Block)
mBlk <- m (Maybe (Entity Block))
-> ExceptT Failure m (Maybe (Entity Block))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe (Entity Block))
 -> ExceptT Failure m (Maybe (Entity Block)))
-> m (Maybe (Entity Block))
-> ExceptT Failure m (Maybe (Entity Block))
forall a b. (a -> b) -> a -> b
$ ReaderT SqlBackend m (Maybe (Entity Block))
-> m (Maybe (Entity Block))
forall (m :: * -> *) a. Storage m => ReaderT SqlBackend m a -> m a
runSql ReaderT SqlBackend m (Maybe (Entity Block))
forall (m :: * -> *).
MonadIO m =>
ReaderT SqlBackend m (Maybe (Entity Block))
Block.getLatestSql
  BlkHeight
cHeight <-
    Text -> Integer -> ExceptT Failure m BlkHeight
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
"BlockScanner block count"
      (Integer -> ExceptT Failure m BlkHeight)
-> ExceptT Failure m Integer -> ExceptT Failure m BlkHeight
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Client -> IO Integer)
-> (IO Integer -> IO Integer) -> ExceptT Failure m Integer
forall (m :: * -> *) a b.
Env m =>
(Client -> a) -> (a -> IO b) -> ExceptT Failure m b
withBtcT Client -> IO Integer
Btc.getBlockCount IO Integer -> IO Integer
forall a. a -> a
id
  case Maybe (Entity Block)
mBlk of
    Maybe (Entity Block)
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
"Found no blocks, scanning height = "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlkHeight -> Text
forall a. Out a => a -> Text
inspect BlkHeight
cHeight
      BlkHeight -> ExceptT Failure m [Utxo]
forall (m :: * -> *).
Env m =>
BlkHeight -> ExceptT Failure m [Utxo]
scanOneBlock BlkHeight
cHeight
    Just Entity Block
lBlk -> do
      Maybe Integer
reorgDetected <- Entity Block -> ExceptT Failure m (Maybe Integer)
forall (m :: * -> *).
Env m =>
Entity Block -> ExceptT Failure m (Maybe Integer)
detectReorg Entity Block
lBlk
      case Maybe Integer
reorgDetected of
        Maybe Integer
Nothing -> do
          let known :: Word64
known = BlkHeight -> Word64
forall source target.
(From source target, 'False ~ (source == target)) =>
source -> target
from (BlkHeight -> Word64) -> (Block -> BlkHeight) -> Block -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> BlkHeight
blockHeight (Block -> Word64) -> Block -> Word64
forall a b. (a -> b) -> a -> b
$ Entity Block -> Block
forall record. Entity record -> record
entityVal Entity Block
lBlk
          [Utxo] -> Word64 -> Word64 -> ExceptT Failure m [Utxo]
forall (m :: * -> *).
Env m =>
[Utxo] -> Word64 -> Word64 -> ExceptT Failure m [Utxo]
scannerStep [] (Word64
1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
known) (Word64 -> ExceptT Failure m [Utxo])
-> Word64 -> ExceptT Failure m [Utxo]
forall a b. (a -> b) -> a -> b
$ BlkHeight -> Word64
forall source target.
(From source target, 'False ~ (source == target)) =>
source -> target
from BlkHeight
cHeight
        Just Integer
height -> do
          $(logTM) Severity
WarningS (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
"Reorg detected from height = "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Integer -> Text
forall a. Out a => a -> Text
inspect Integer
height
          BlkHeight
bHeight <-
            Text -> Integer -> ExceptT Failure m BlkHeight
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
"BlockScanner reorg block height" Integer
height
          (Entity Block -> Failure)
-> ExceptT (Entity Block) m () -> ExceptT Failure m ()
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT
            ( FailureInternal -> Failure
FailureInt
                (FailureInternal -> Failure)
-> (Entity Block -> FailureInternal) -> Entity Block -> Failure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FailureInternal
FailurePrivate
                (Text -> FailureInternal)
-> (Entity Block -> Text) -> Entity Block -> FailureInternal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"Block scanner failed due to bad status " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)
                (Text -> Text) -> (Entity Block -> Text) -> Entity Block -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity Block -> Text
forall a. Out a => a -> Text
inspectPlain
            )
            (ExceptT (Entity Block) m () -> ExceptT Failure m ())
-> (ReaderT SqlBackend m () -> ExceptT (Entity Block) m ())
-> ReaderT SqlBackend m ()
-> ExceptT Failure m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Either (Entity Block) ()) -> ExceptT (Entity Block) m ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT
            (m (Either (Entity Block) ()) -> ExceptT (Entity Block) m ())
-> (ReaderT SqlBackend m () -> m (Either (Entity Block) ()))
-> ReaderT SqlBackend m ()
-> ExceptT (Entity Block) m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT SqlBackend m (Either (Entity Block) ())
-> m (Either (Entity Block) ())
forall (m :: * -> *) a. Storage m => ReaderT SqlBackend m a -> m a
runSql
            (ReaderT SqlBackend m (Either (Entity Block) ())
 -> m (Either (Entity Block) ()))
-> (ReaderT SqlBackend m ()
    -> ReaderT SqlBackend m (Either (Entity Block) ()))
-> ReaderT SqlBackend m ()
-> m (Either (Entity Block) ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key Block
-> (BlkStatus -> Bool)
-> (Block -> ReaderT SqlBackend m ())
-> ReaderT SqlBackend m (Either (Entity Block) ())
forall (m :: * -> *) a.
MonadIO m =>
Key Block
-> (BlkStatus -> Bool)
-> (Block -> ReaderT SqlBackend m a)
-> ReaderT SqlBackend m (Either (Entity Block) a)
Block.withLockedRowSql
              (Entity Block -> Key Block
forall record. Entity record -> Key record
entityKey Entity Block
lBlk)
              (BlkStatus -> BlkStatus -> Bool
forall a. Eq a => a -> a -> Bool
== BlkStatus
BlkConfirmed)
            ((Block -> ReaderT SqlBackend m ())
 -> ReaderT SqlBackend m (Either (Entity Block) ()))
-> (ReaderT SqlBackend m () -> Block -> ReaderT SqlBackend m ())
-> ReaderT SqlBackend m ()
-> ReaderT SqlBackend m (Either (Entity Block) ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT SqlBackend m () -> Block -> ReaderT SqlBackend m ()
forall a b. a -> b -> a
const
            (ReaderT SqlBackend m () -> ExceptT Failure m ())
-> ReaderT SqlBackend m () -> ExceptT Failure m ()
forall a b. (a -> b) -> a -> b
$ do
              [Entity Block]
blks <- BlkHeight -> ReaderT SqlBackend m [Entity Block]
forall (m :: * -> *).
MonadIO m =>
BlkHeight -> ReaderT SqlBackend m [Entity Block]
Block.getBlocksHigherSql BlkHeight
bHeight
              BlkHeight -> ReaderT SqlBackend m ()
forall (m :: * -> *).
MonadIO m =>
BlkHeight -> ReaderT SqlBackend m ()
Block.updateOrphanHigherSql BlkHeight
bHeight
              [Key Block] -> ReaderT SqlBackend m ()
forall (m :: * -> *).
MonadIO m =>
[Key Block] -> ReaderT SqlBackend m ()
SwapUtxo.revertRefundedSql (Entity Block -> Key Block
forall record. Entity record -> Key record
entityKey (Entity Block -> Key Block) -> [Entity Block] -> [Key Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Entity Block]
blks)
              [Key Block] -> ReaderT SqlBackend m ()
forall (m :: * -> *).
MonadIO m =>
[Key Block] -> ReaderT SqlBackend m ()
SwapUtxo.updateOrphanSql (Entity Block -> Key Block
forall record. Entity record -> Key record
entityKey (Entity Block -> Key Block) -> [Entity Block] -> [Key Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Entity Block]
blks)
          [Utxo] -> Word64 -> Word64 -> ExceptT Failure m [Utxo]
forall (m :: * -> *).
Env m =>
[Utxo] -> Word64 -> Word64 -> ExceptT Failure m [Utxo]
scannerStep [] (Word64
1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ BlkHeight -> Word64
coerce BlkHeight
bHeight) (Word64 -> ExceptT Failure m [Utxo])
-> Word64 -> ExceptT Failure m [Utxo]
forall a b. (a -> b) -> a -> b
$ BlkHeight -> Word64
forall source target.
(From source target, 'False ~ (source == target)) =>
source -> target
from BlkHeight
cHeight

scannerStep ::
  ( Env m
  ) =>
  [Utxo] ->
  Word64 ->
  Word64 ->
  ExceptT Failure m [Utxo]
scannerStep :: forall (m :: * -> *).
Env m =>
[Utxo] -> Word64 -> Word64 -> ExceptT Failure m [Utxo]
scannerStep [Utxo]
acc Word64
cur Word64
end =
  if Word64
cur Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
end
    then [Utxo] -> ExceptT Failure m [Utxo]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Utxo]
acc
    else 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
"Scanner step cur = "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Out a => a -> Text
inspect Word64
cur
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" end = "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Out a => a -> Text
inspect Word64
end
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" got utxos qty = "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Out a => a -> Text
inspect ([Utxo] -> Int
forall t. Container t => t -> Int
length [Utxo]
acc)
      [Utxo]
utxos <- BlkHeight -> ExceptT Failure m [Utxo]
forall (m :: * -> *).
Env m =>
BlkHeight -> ExceptT Failure m [Utxo]
scanOneBlock (Word64 -> BlkHeight
BlkHeight Word64
cur)
      [Utxo] -> Word64 -> Word64 -> ExceptT Failure m [Utxo]
forall (m :: * -> *).
Env m =>
[Utxo] -> Word64 -> Word64 -> ExceptT Failure m [Utxo]
scannerStep ([Utxo]
acc [Utxo] -> [Utxo] -> [Utxo]
forall a. Semigroup a => a -> a -> a
<> [Utxo]
utxos) (Word64
cur Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1) Word64
end

detectReorg ::
  ( Env m
  ) =>
  Entity Block ->
  ExceptT Failure m (Maybe Btc.BlockHeight)
detectReorg :: forall (m :: * -> *).
Env m =>
Entity Block -> ExceptT Failure m (Maybe Integer)
detectReorg Entity Block
blk = do
  Integer
cReorgHeight <- Integer -> ExceptT Failure m Integer
forall (m :: * -> *). Env m => Integer -> ExceptT Failure m Integer
checkReorgHeight Integer
cHeight
  Maybe Integer -> ExceptT Failure m (Maybe Integer)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Integer -> ExceptT Failure m (Maybe Integer))
-> Maybe Integer -> ExceptT Failure m (Maybe Integer)
forall a b. (a -> b) -> a -> b
$
    if Integer
cReorgHeight Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
cHeight
      then Maybe Integer
forall a. Maybe a
Nothing
      else Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
cReorgHeight
  where
    cHeight :: Integer
cHeight =
      BlkHeight -> Integer
forall source target.
(From source target, 'False ~ (source == target)) =>
source -> target
from (BlkHeight -> Integer) -> (Block -> BlkHeight) -> Block -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> BlkHeight
blockHeight (Block -> Integer) -> Block -> Integer
forall a b. (a -> b) -> a -> b
$ Entity Block -> Block
forall record. Entity record -> record
entityVal Entity Block
blk

checkReorgHeight ::
  ( Env m
  ) =>
  Btc.BlockHeight ->
  ExceptT Failure m Btc.BlockHeight
checkReorgHeight :: forall (m :: * -> *). Env m => Integer -> ExceptT Failure m Integer
checkReorgHeight Integer
bHeight = do
  Maybe Bool
res <- Integer -> ExceptT Failure m (Maybe Bool)
forall (m :: * -> *).
Env m =>
Integer -> ExceptT Failure m (Maybe Bool)
compareHash Integer
bHeight
  case Maybe Bool
res of
    Just Bool
True -> Integer -> ExceptT Failure m Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
bHeight
    Just Bool
False -> Integer -> ExceptT Failure m Integer
forall (m :: * -> *). Env m => Integer -> ExceptT Failure m Integer
checkReorgHeight (Integer
bHeight Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)
    Maybe Bool
Nothing -> Integer -> ExceptT Failure m Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
bHeight

compareHash ::
  ( Env m
  ) =>
  Btc.BlockHeight ->
  ExceptT Failure m (Maybe Bool)
compareHash :: forall (m :: * -> *).
Env m =>
Integer -> ExceptT Failure m (Maybe Bool)
compareHash Integer
height = do
  Word64
w64h <- Text -> Integer -> ExceptT Failure m Word64
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
"BlockScanner compareHash" Integer
height
  Text
cHash <- (Client -> Integer -> IO Text)
-> ((Integer -> IO Text) -> IO Text) -> ExceptT Failure m Text
forall (m :: * -> *) a b.
Env m =>
(Client -> a) -> (a -> IO b) -> ExceptT Failure m b
withBtcT Client -> Integer -> IO Text
Btc.getBlockHash ((Integer -> IO Text) -> Integer -> IO Text
forall a b. (a -> b) -> a -> b
$ Integer
height)
  m (Maybe Bool) -> ExceptT Failure m (Maybe Bool)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
    (m (Maybe Bool) -> ExceptT Failure m (Maybe Bool))
-> (BlkHeight -> m (Maybe Bool))
-> BlkHeight
-> ExceptT Failure m (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
cHash)
          (Text -> Bool) -> (Entity Block -> Text) -> Entity Block -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlkHash -> Text
coerce
          (BlkHash -> Text)
-> (Entity Block -> BlkHash) -> Entity Block -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> BlkHash
blockHash
          (Block -> BlkHash)
-> (Entity Block -> Block) -> Entity Block -> BlkHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity Block -> Block
forall record. Entity record -> record
entityVal
          (Entity Block -> Bool)
-> m (Maybe (Entity Block)) -> m (Maybe Bool)
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<<$>>
      )
    (m (Maybe (Entity Block)) -> m (Maybe Bool))
-> (BlkHeight -> m (Maybe (Entity Block)))
-> BlkHeight
-> m (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Entity Block] -> Maybe (Entity Block)
forall a. [a] -> Maybe a
listToMaybe ([Entity Block] -> Maybe (Entity Block))
-> m [Entity Block] -> m (Maybe (Entity Block))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
    (m [Entity Block] -> m (Maybe (Entity Block)))
-> (BlkHeight -> m [Entity Block])
-> BlkHeight
-> m (Maybe (Entity Block))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT SqlBackend m [Entity Block] -> m [Entity Block]
forall (m :: * -> *) a. Storage m => ReaderT SqlBackend m a -> m a
runSql
    (ReaderT SqlBackend m [Entity Block] -> m [Entity Block])
-> (BlkHeight -> ReaderT SqlBackend m [Entity Block])
-> BlkHeight
-> m [Entity Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlkHeight -> ReaderT SqlBackend m [Entity Block]
forall (m :: * -> *).
MonadIO m =>
BlkHeight -> ReaderT SqlBackend m [Entity Block]
Block.getBlockByHeightSql
    (BlkHeight -> ExceptT Failure m (Maybe Bool))
-> BlkHeight -> ExceptT Failure m (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Word64 -> BlkHeight
BlkHeight Word64
w64h

scanOneBlock ::
  ( Env m
  ) =>
  BlkHeight ->
  ExceptT Failure m [Utxo]
scanOneBlock :: forall (m :: * -> *).
Env m =>
BlkHeight -> ExceptT Failure m [Utxo]
scanOneBlock BlkHeight
height = do
  Text
hash <- (Client -> Integer -> IO Text)
-> ((Integer -> IO Text) -> IO Text) -> ExceptT Failure m Text
forall (m :: * -> *) a b.
Env m =>
(Client -> a) -> (a -> IO b) -> ExceptT Failure m b
withBtcT Client -> Integer -> IO Text
Btc.getBlockHash ((Integer -> IO Text) -> Integer -> IO Text
forall a b. (a -> b) -> a -> b
$ BlkHeight -> Integer
forall source target.
(From source target, 'False ~ (source == target)) =>
source -> target
from BlkHeight
height)
  BlockVerbose
blk <- (Client -> Text -> IO BlockVerbose)
-> ((Text -> IO BlockVerbose) -> IO BlockVerbose)
-> ExceptT Failure m BlockVerbose
forall (m :: * -> *) a b.
Env m =>
(Client -> a) -> (a -> IO b) -> ExceptT Failure m b
withBtcT Client -> Text -> IO BlockVerbose
Btc.getBlockVerbose ((Text -> IO BlockVerbose) -> Text -> IO BlockVerbose
forall a b. (a -> b) -> a -> b
$ Text
hash)
  $(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
"Got new block with height = "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlkHeight -> Text
forall a. Out a => a -> Text
inspect BlkHeight
height
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and hash = "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Out a => a -> Text
inspect Text
hash
  [Utxo]
utxos <- m [Utxo] -> ExceptT Failure m [Utxo]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [Utxo] -> ExceptT Failure m [Utxo])
-> m [Utxo] -> ExceptT Failure m [Utxo]
forall a b. (a -> b) -> a -> b
$ BlockVerbose -> m [Utxo]
forall (m :: * -> *). Env m => BlockVerbose -> m [Utxo]
extractRelatedUtxoFromBlock BlockVerbose
blk
  [Utxo]
lockedUtxos <- (Utxo -> ExceptT Failure m Utxo)
-> [Utxo] -> ExceptT Failure m [Utxo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Utxo -> ExceptT Failure m Utxo
forall (m :: * -> *). Env m => Utxo -> ExceptT Failure m Utxo
lockUtxo' [Utxo]
utxos
  BlockVerbose -> [Utxo] -> ExceptT Failure m ()
forall (m :: * -> *).
(Storage m, Env m) =>
BlockVerbose -> [Utxo] -> ExceptT Failure m ()
persistBlockT BlockVerbose
blk [Utxo]
lockedUtxos
  [Utxo] -> ExceptT Failure m [Utxo]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Utxo]
utxos

--
-- TODO : Verify that it's possible to lock already locked UTXO.
-- It's corner case where UTXO has been locked but storage
-- procedure later failed.
--

utxoToOutPoint :: Utxo -> OP.OutPoint
utxoToOutPoint :: Utxo -> OutPoint
utxoToOutPoint Utxo
u = ByteString -> Word32 -> OutPoint
OP.OutPoint (TxId 'Funding -> ByteString
coerce (TxId 'Funding -> ByteString) -> TxId 'Funding -> ByteString
forall a b. (a -> b) -> a -> b
$ Utxo -> TxId 'Funding
utxoTxId Utxo
u) (Vout 'Funding -> Word32
coerce (Vout 'Funding -> Word32) -> Vout 'Funding -> Word32
forall a b. (a -> b) -> a -> b
$ Utxo -> Vout 'Funding
utxoVout Utxo
u)

lockUtxo' :: Env m => Utxo -> ExceptT Failure m Utxo
lockUtxo' :: forall (m :: * -> *). Env m => Utxo -> ExceptT Failure m Utxo
lockUtxo' Utxo
u = do
  UtxoLease
l <- OutPoint -> ExceptT Failure m UtxoLease
forall (m :: * -> *).
Env m =>
OutPoint -> ExceptT Failure m UtxoLease
lockUtxo (Utxo -> OutPoint
utxoToOutPoint Utxo
u)
  Utxo -> ExceptT Failure m Utxo
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Utxo -> ExceptT Failure m Utxo) -> Utxo -> ExceptT Failure m Utxo
forall a b. (a -> b) -> a -> b
$ Utxo
u {utxoLockId :: Maybe UtxoLockId
utxoLockId = UtxoLockId -> Maybe UtxoLockId
forall a. a -> Maybe a
Just (UtxoLockId -> Maybe UtxoLockId) -> UtxoLockId -> Maybe UtxoLockId
forall a b. (a -> b) -> a -> b
$ ByteString -> UtxoLockId
UtxoLockId (ByteString -> UtxoLockId) -> ByteString -> UtxoLockId
forall a b. (a -> b) -> a -> b
$ UtxoLease -> ByteString
FP.id UtxoLease
l}

maybeSwap ::
  ( Env m
  ) =>
  Btc.Address ->
  m (Maybe (Entity SwapIntoLn))
maybeSwap :: forall (m :: * -> *).
Env m =>
Text -> m (Maybe (Entity SwapIntoLn))
maybeSwap =
  ReaderT SqlBackend m (Maybe (Entity SwapIntoLn))
-> m (Maybe (Entity SwapIntoLn))
forall (m :: * -> *) a. Storage m => ReaderT SqlBackend m a -> m a
runSql
    (ReaderT SqlBackend m (Maybe (Entity SwapIntoLn))
 -> m (Maybe (Entity SwapIntoLn)))
-> (Text -> ReaderT SqlBackend m (Maybe (Entity SwapIntoLn)))
-> Text
-> m (Maybe (Entity SwapIntoLn))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnChainAddress 'Fund
-> ReaderT SqlBackend m (Maybe (Entity SwapIntoLn))
forall (m :: * -> *).
MonadIO m =>
OnChainAddress 'Fund
-> ReaderT SqlBackend m (Maybe (Entity SwapIntoLn))
SwapIntoLn.getByFundAddressSql
    (OnChainAddress 'Fund
 -> ReaderT SqlBackend m (Maybe (Entity SwapIntoLn)))
-> (Text -> OnChainAddress 'Fund)
-> Text
-> ReaderT SqlBackend m (Maybe (Entity SwapIntoLn))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> OnChainAddress 'Fund
forall (mrel :: MoneyRelation). Text -> OnChainAddress mrel
Smart.unsafeNewOnChainAddress

monitorOnChainLiquidity ::
  ( Env m
  ) =>
  ExceptT Failure m ()
monitorOnChainLiquidity :: forall (m :: * -> *). Env m => ExceptT Failure m ()
monitorOnChainLiquidity =
  (LndEnv -> m (Either LndError WalletBalance))
-> (m (Either LndError WalletBalance)
    -> m (Either LndError WalletBalance))
-> ExceptT Failure m WalletBalance
forall (m :: * -> *) a b.
Env m =>
(LndEnv -> a)
-> (a -> m (Either LndError b)) -> ExceptT Failure m b
withLndT LndEnv -> m (Either LndError WalletBalance)
forall (m :: * -> *).
(KatipContext m, MonadUnliftIO m) =>
LndEnv -> m (Either LndError WalletBalance)
Lnd.walletBalance m (Either LndError WalletBalance)
-> m (Either LndError WalletBalance)
forall a. a -> a
id
    ExceptT Failure m WalletBalance
-> (WalletBalance -> ExceptT Failure m ()) -> ExceptT Failure m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m () -> ExceptT Failure m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT Failure m ())
-> (WalletBalance -> m ()) -> WalletBalance -> ExceptT Failure m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WalletBalance -> m ()
forall (m :: * -> *). Env m => WalletBalance -> m ()
monitorTotalOnChainLiquidity