{-# LANGUAGE ConstraintKinds   #-}
{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TupleSections     #-}
module Haskoin.Store.Logic
    ( ImportException (..)
    , MonadImport
    , initBest
    , revertBlock
    , importBlock
    , newMempoolTx
    , deleteUnconfirmedTx
    , streamThings
    , joinStreams
    ) where

import           Conduit               (ConduitT, await, lift, sealConduitT,
                                        yield, ($$++))
import           Control.Monad         (forM, forM_, guard, unless, void, when,
                                        zipWithM_)
import           Control.Monad.Except  (MonadError, throwError)
import           Control.Monad.Logger  (MonadLoggerIO (..), logDebugS,
                                        logErrorS)
import qualified Data.ByteString       as B
import           Data.Either           (rights)
import           Data.Function         (on)
import qualified Data.IntMap.Strict    as I
import           Data.List             (nub, sortBy)
import           Data.Maybe            (catMaybes, fromMaybe, isJust, isNothing,
                                        mapMaybe)
import           Data.Serialize        (encode)
import           Data.Word             (Word32, Word64)
import           Haskoin               (Address, Block (..), BlockHash,
                                        BlockHeader (..), BlockNode (..),
                                        Network (..), OutPoint (..), Tx (..),
                                        TxHash, TxIn (..), TxOut (..),
                                        blockHashToHex, computeSubsidy,
                                        eitherToMaybe, genesisBlock,
                                        genesisNode, headerHash, isGenesis,
                                        nullOutPoint, scriptToAddressBS, txHash,
                                        txHashToHex)
import           Haskoin.Store.Common
import           Haskoin.Store.Data    (Balance (..), BlockData (..),
                                        BlockRef (..), Prev (..), Spender (..),
                                        TxData (..), TxRef (..), UnixTime,
                                        Unspent (..), confirmed)
import           UnliftIO              (Exception)

type MonadImport m =
    ( MonadError ImportException m
    , MonadLoggerIO m
    , StoreReadBase m
    , StoreWrite m
    )

data ImportException
    = PrevBlockNotBest
    | Orphan
    | UnexpectedCoinbase
    | BestBlockNotFound
    | BlockNotBest
    | TxNotFound
    | DoubleSpend
    | TxConfirmed
    | InsufficientFunds
    | DuplicatePrevOutput
    | TxSpent
    | OrphanLoop
    deriving (ImportException -> ImportException -> Bool
(ImportException -> ImportException -> Bool)
-> (ImportException -> ImportException -> Bool)
-> Eq ImportException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ImportException -> ImportException -> Bool
$c/= :: ImportException -> ImportException -> Bool
== :: ImportException -> ImportException -> Bool
$c== :: ImportException -> ImportException -> Bool
Eq, Eq ImportException
Eq ImportException =>
(ImportException -> ImportException -> Ordering)
-> (ImportException -> ImportException -> Bool)
-> (ImportException -> ImportException -> Bool)
-> (ImportException -> ImportException -> Bool)
-> (ImportException -> ImportException -> Bool)
-> (ImportException -> ImportException -> ImportException)
-> (ImportException -> ImportException -> ImportException)
-> Ord ImportException
ImportException -> ImportException -> Bool
ImportException -> ImportException -> Ordering
ImportException -> ImportException -> ImportException
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ImportException -> ImportException -> ImportException
$cmin :: ImportException -> ImportException -> ImportException
max :: ImportException -> ImportException -> ImportException
$cmax :: ImportException -> ImportException -> ImportException
>= :: ImportException -> ImportException -> Bool
$c>= :: ImportException -> ImportException -> Bool
> :: ImportException -> ImportException -> Bool
$c> :: ImportException -> ImportException -> Bool
<= :: ImportException -> ImportException -> Bool
$c<= :: ImportException -> ImportException -> Bool
< :: ImportException -> ImportException -> Bool
$c< :: ImportException -> ImportException -> Bool
compare :: ImportException -> ImportException -> Ordering
$ccompare :: ImportException -> ImportException -> Ordering
$cp1Ord :: Eq ImportException
Ord, Show ImportException
Typeable ImportException
(Typeable ImportException, Show ImportException) =>
(ImportException -> SomeException)
-> (SomeException -> Maybe ImportException)
-> (ImportException -> String)
-> Exception ImportException
SomeException -> Maybe ImportException
ImportException -> String
ImportException -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
displayException :: ImportException -> String
$cdisplayException :: ImportException -> String
fromException :: SomeException -> Maybe ImportException
$cfromException :: SomeException -> Maybe ImportException
toException :: ImportException -> SomeException
$ctoException :: ImportException -> SomeException
$cp2Exception :: Show ImportException
$cp1Exception :: Typeable ImportException
Exception)

instance Show ImportException where
    show :: ImportException -> String
show PrevBlockNotBest    = "Previous block not best"
    show Orphan              = "Orphan"
    show UnexpectedCoinbase  = "Unexpected coinbase"
    show BestBlockNotFound   = "Best block not found"
    show BlockNotBest        = "Block not best"
    show TxNotFound          = "Transaction not found"
    show DoubleSpend         = "Double spend"
    show TxConfirmed         = "Transaction confirmed"
    show InsufficientFunds   = "Insufficient funds"
    show DuplicatePrevOutput = "Duplicate previous output"
    show TxSpent             = "Transaction is spent"
    show OrphanLoop          = "Orphan loop"

initBest :: MonadImport m => m ()
initBest :: m ()
initBest = do
    $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
logDebugS) "BlockStore" "Initializing best block"
    Network
net <- m Network
forall (m :: * -> *). StoreReadBase m => m Network
getNetwork
    Maybe BlockHash
m <- m (Maybe BlockHash)
forall (m :: * -> *). StoreReadBase m => m (Maybe BlockHash)
getBestBlock
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe BlockHash -> Bool
forall a. Maybe a -> Bool
isNothing Maybe BlockHash
m) (m () -> m ()) -> (m () -> m ()) -> m () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "BlockStore" "Importing Genesis block"
        Block -> BlockNode -> m ()
forall (m :: * -> *). MonadImport m => Block -> BlockNode -> m ()
importBlock (Network -> Block
genesisBlock Network
net) (Network -> BlockNode
genesisNode Network
net)

getOldMempool :: StoreReadBase m => UnixTime -> m [TxHash]
getOldMempool :: UnixTime -> m [TxHash]
getOldMempool now :: UnixTime
now =
    ((UnixTime, TxHash) -> TxHash) -> [(UnixTime, TxHash)] -> [TxHash]
forall a b. (a -> b) -> [a] -> [b]
map (UnixTime, TxHash) -> TxHash
forall a b. (a, b) -> b
snd ([(UnixTime, TxHash)] -> [TxHash])
-> ([(UnixTime, TxHash)] -> [(UnixTime, TxHash)])
-> [(UnixTime, TxHash)]
-> [TxHash]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UnixTime, TxHash) -> Bool)
-> [(UnixTime, TxHash)] -> [(UnixTime, TxHash)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((UnixTime -> UnixTime -> Bool
forall a. Ord a => a -> a -> Bool
< UnixTime
now UnixTime -> UnixTime -> UnixTime
forall a. Num a => a -> a -> a
- 3600 UnixTime -> UnixTime -> UnixTime
forall a. Num a => a -> a -> a
* 72) (UnixTime -> Bool)
-> ((UnixTime, TxHash) -> UnixTime) -> (UnixTime, TxHash) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnixTime, TxHash) -> UnixTime
forall a b. (a, b) -> a
fst) ([(UnixTime, TxHash)] -> [TxHash])
-> m [(UnixTime, TxHash)] -> m [TxHash]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [(UnixTime, TxHash)]
forall (m :: * -> *). StoreReadBase m => m [(UnixTime, TxHash)]
getMempool

newMempoolTx :: MonadImport m => Tx -> UnixTime -> m Bool
newMempoolTx :: Tx -> UnixTime -> m Bool
newMempoolTx tx :: Tx
tx w :: UnixTime
w =
    TxHash -> m (Maybe TxData)
forall (m :: * -> *). StoreReadBase m => TxHash -> m (Maybe TxData)
getActiveTxData (Tx -> TxHash
txHash Tx
tx) m (Maybe TxData) -> (Maybe TxData -> m Bool) -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just _ ->
            Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Nothing -> do
            Bool -> Bool -> Tx -> m ()
forall (m :: * -> *). MonadImport m => Bool -> Bool -> Tx -> m ()
freeOutputs Bool
True Bool
True Tx
tx
            Bool
rbf <- BlockRef -> Tx -> m Bool
forall (m :: * -> *). StoreReadBase m => BlockRef -> Tx -> m Bool
isRBF (UnixTime -> BlockRef
MemRef UnixTime
w) Tx
tx
            Tx -> m ()
forall (m :: * -> *). MonadImport m => Tx -> m ()
checkNewTx Tx
tx
            BlockRef -> UnixTime -> Bool -> Tx -> m ()
forall (m :: * -> *).
MonadImport m =>
BlockRef -> UnixTime -> Bool -> Tx -> m ()
importTx (UnixTime -> BlockRef
MemRef UnixTime
w) UnixTime
w Bool
rbf Tx
tx
            Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

bestBlockData :: MonadImport m => m BlockData
bestBlockData :: m BlockData
bestBlockData = do
    BlockHash
h <- m (Maybe BlockHash)
forall (m :: * -> *). StoreReadBase m => m (Maybe BlockHash)
getBestBlock m (Maybe BlockHash)
-> (Maybe BlockHash -> m BlockHash) -> m BlockHash
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Nothing -> do
            $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" "Best block unknown"
            ImportException -> m BlockHash
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
BestBlockNotFound
        Just h :: BlockHash
h -> BlockHash -> m BlockHash
forall (m :: * -> *) a. Monad m => a -> m a
return BlockHash
h
    BlockHash -> m (Maybe BlockData)
forall (m :: * -> *).
StoreReadBase m =>
BlockHash -> m (Maybe BlockData)
getBlock BlockHash
h m (Maybe BlockData)
-> (Maybe BlockData -> m BlockData) -> m BlockData
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Nothing -> do
            $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" "Best block not found"
            ImportException -> m BlockData
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
BestBlockNotFound
        Just b :: BlockData
b -> BlockData -> m BlockData
forall (m :: * -> *) a. Monad m => a -> m a
return BlockData
b

revertBlock :: MonadImport m => BlockHash -> m ()
revertBlock :: BlockHash -> m ()
revertBlock bh :: BlockHash
bh = do
    BlockData
bd <- m BlockData
forall (m :: * -> *). MonadImport m => m BlockData
bestBlockData m BlockData -> (BlockData -> m BlockData) -> m BlockData
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b :: BlockData
b ->
        if BlockHeader -> BlockHash
headerHash (BlockData -> BlockHeader
blockDataHeader BlockData
b) BlockHash -> BlockHash -> Bool
forall a. Eq a => a -> a -> Bool
== BlockHash
bh
        then BlockData -> m BlockData
forall (m :: * -> *) a. Monad m => a -> m a
return BlockData
b
        else do
            $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                "Cannot revert non-head block: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
bh
            ImportException -> m BlockData
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
BlockNotBest
    [TxData]
tds <- (TxHash -> m TxData) -> [TxHash] -> m [TxData]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TxHash -> m TxData
forall (m :: * -> *). MonadImport m => TxHash -> m TxData
getImportTxData (BlockData -> [TxHash]
blockDataTxs BlockData
bd)
    BlockHash -> m ()
forall (m :: * -> *). StoreWrite m => BlockHash -> m ()
setBest (BlockHeader -> BlockHash
prevBlock (BlockData -> BlockHeader
blockDataHeader BlockData
bd))
    BlockData -> m ()
forall (m :: * -> *). StoreWrite m => BlockData -> m ()
insertBlock BlockData
bd {blockDataMainChain :: Bool
blockDataMainChain = Bool
False}
    [TxData] -> (TxData -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([TxData] -> [TxData]
forall a. [a] -> [a]
tail [TxData]
tds) TxData -> m ()
forall (m :: * -> *). MonadImport m => TxData -> m ()
unConfirmTx
    TxHash -> m ()
forall (m :: * -> *). MonadImport m => TxHash -> m ()
deleteConfirmedTx (Tx -> TxHash
txHash (TxData -> Tx
txData ([TxData] -> TxData
forall a. [a] -> a
head [TxData]
tds)))

checkNewBlock :: MonadImport m => Block -> BlockNode -> m ()
checkNewBlock :: Block -> BlockNode -> m ()
checkNewBlock b :: Block
b n :: BlockNode
n =
    m (Maybe BlockHash)
forall (m :: * -> *). StoreReadBase m => m (Maybe BlockHash)
getBestBlock m (Maybe BlockHash) -> (Maybe BlockHash -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Nothing
            | BlockNode -> Bool
isGenesis BlockNode
n -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            | Bool
otherwise -> do
                $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                    "Cannot import non-genesis block: "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex (BlockHeader -> BlockHash
headerHash (Block -> BlockHeader
blockHeader Block
b))
                ImportException -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
BestBlockNotFound
        Just h :: BlockHash
h
            | BlockHeader -> BlockHash
prevBlock (Block -> BlockHeader
blockHeader Block
b) BlockHash -> BlockHash -> Bool
forall a. Eq a => a -> a -> Bool
== BlockHash
h -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            | Bool
otherwise -> do
                $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                    "Block does not build on head: "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex (BlockHeader -> BlockHash
headerHash (Block -> BlockHeader
blockHeader Block
b))
                ImportException -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
PrevBlockNotBest

importOrConfirm :: MonadImport m => BlockNode -> [Tx] -> m ()
importOrConfirm :: BlockNode -> [Tx] -> m ()
importOrConfirm bn :: BlockNode
bn txns :: [Tx]
txns = do
    ((Word32, Tx) -> m ()) -> [(Word32, Tx)] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> Bool -> Tx -> m ()
forall (m :: * -> *). MonadImport m => Bool -> Bool -> Tx -> m ()
freeOutputs Bool
True Bool
False (Tx -> m ()) -> ((Word32, Tx) -> Tx) -> (Word32, Tx) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word32, Tx) -> Tx
forall a b. (a, b) -> b
snd) ([(Word32, Tx)] -> [(Word32, Tx)]
forall a. [a] -> [a]
reverse [(Word32, Tx)]
txs)
    ((Word32, Tx) -> m (Maybe Any)) -> [(Word32, Tx)] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Word32 -> Tx -> m (Maybe Any)) -> (Word32, Tx) -> m (Maybe Any)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Word32 -> Tx -> m (Maybe Any)
forall (m :: * -> *) a.
(StoreReadBase m, MonadError ImportException m, MonadLoggerIO m,
 StoreWrite m) =>
Word32 -> Tx -> m (Maybe a)
action) [(Word32, Tx)]
txs
  where
    txs :: [(Word32, Tx)]
txs = [Tx] -> [(Word32, Tx)]
sortTxs [Tx]
txns
    br :: Word32 -> BlockRef
br i :: Word32
i = $WBlockRef :: Word32 -> Word32 -> BlockRef
BlockRef {blockRefHeight :: Word32
blockRefHeight = BlockNode -> Word32
nodeHeight BlockNode
bn, blockRefPos :: Word32
blockRefPos = Word32
i}
    bn_time :: UnixTime
bn_time = Word32 -> UnixTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> UnixTime)
-> (BlockHeader -> Word32) -> BlockHeader -> UnixTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHeader -> Word32
blockTimestamp (BlockHeader -> UnixTime) -> BlockHeader -> UnixTime
forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeader
nodeHeader BlockNode
bn
    action :: Word32 -> Tx -> m (Maybe a)
action i :: Word32
i tx :: Tx
tx =
        Tx -> m Bool
forall (m :: * -> *). StoreReadBase m => Tx -> m Bool
testPresent Tx
tx m Bool -> (Bool -> m (Maybe a)) -> m (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            False -> Word32 -> Tx -> m (Maybe a)
forall (m :: * -> *) a.
(MonadError ImportException m, MonadLoggerIO m, StoreReadBase m,
 StoreWrite m) =>
Word32 -> Tx -> m (Maybe a)
import_it Word32
i Tx
tx
            True  -> Word32 -> Tx -> m (Maybe a)
forall (m :: * -> *) a.
(StoreReadBase m, MonadError ImportException m, MonadLoggerIO m,
 StoreWrite m) =>
Word32 -> Tx -> m (Maybe a)
confirm_it Word32
i Tx
tx
    confirm_it :: Word32 -> Tx -> m (Maybe a)
confirm_it i :: Word32
i tx :: Tx
tx =
        TxHash -> m (Maybe TxData)
forall (m :: * -> *). StoreReadBase m => TxHash -> m (Maybe TxData)
getActiveTxData (Tx -> TxHash
txHash Tx
tx) m (Maybe TxData) -> (Maybe TxData -> m (Maybe a)) -> m (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just t :: TxData
t -> do
                $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                    "Confirming tx: "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
                TxData -> BlockRef -> m ()
forall (m :: * -> *). MonadImport m => TxData -> BlockRef -> m ()
confirmTx TxData
t (Word32 -> BlockRef
br Word32
i)
                Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
            Nothing -> do
                $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                    "Cannot find tx to confirm: "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
                ImportException -> m (Maybe a)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
TxNotFound
    import_it :: Word32 -> Tx -> m (Maybe a)
import_it i :: Word32
i tx :: Tx
tx = do
        $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            "Importing tx: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
        BlockRef -> UnixTime -> Bool -> Tx -> m ()
forall (m :: * -> *).
MonadImport m =>
BlockRef -> UnixTime -> Bool -> Tx -> m ()
importTx (Word32 -> BlockRef
br Word32
i) UnixTime
bn_time Bool
False Tx
tx
        Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

importBlock :: MonadImport m => Block -> BlockNode -> m ()
importBlock :: Block -> BlockNode -> m ()
importBlock b :: Block
b n :: BlockNode
n = do
    $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        "Checking new block: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex (BlockHeader -> BlockHash
headerHash (BlockNode -> BlockHeader
nodeHeader BlockNode
n))
    Block -> BlockNode -> m ()
forall (m :: * -> *). MonadImport m => Block -> BlockNode -> m ()
checkNewBlock Block
b BlockNode
n
    $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "BlockStore" "Passed check"
    Network
net <- m Network
forall (m :: * -> *). StoreReadBase m => m Network
getNetwork
    let subsidy :: UnixTime
subsidy = Network -> Word32 -> UnixTime
computeSubsidy Network
net (BlockNode -> Word32
nodeHeight BlockNode
n)
    [BlockHash]
bs <- Word32 -> m [BlockHash]
forall (m :: * -> *). StoreReadBase m => Word32 -> m [BlockHash]
getBlocksAtHeight (BlockNode -> Word32
nodeHeight BlockNode
n)
    $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        "Inserting block entries for: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex (BlockHeader -> BlockHash
headerHash (BlockNode -> BlockHeader
nodeHeader BlockNode
n))
    BlockData -> m ()
forall (m :: * -> *). StoreWrite m => BlockData -> m ()
insertBlock
        $WBlockData :: Word32
-> Bool
-> Integer
-> BlockHeader
-> Word32
-> Word32
-> [TxHash]
-> UnixTime
-> UnixTime
-> UnixTime
-> BlockData
BlockData
            { blockDataHeight :: Word32
blockDataHeight = BlockNode -> Word32
nodeHeight BlockNode
n
            , blockDataMainChain :: Bool
blockDataMainChain = Bool
True
            , blockDataWork :: Integer
blockDataWork = BlockNode -> Integer
nodeWork BlockNode
n
            , blockDataHeader :: BlockHeader
blockDataHeader = BlockNode -> BlockHeader
nodeHeader BlockNode
n
            , blockDataSize :: Word32
blockDataSize = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length (Block -> ByteString
forall a. Serialize a => a -> ByteString
encode Block
b))
            , blockDataTxs :: [TxHash]
blockDataTxs = (Tx -> TxHash) -> [Tx] -> [TxHash]
forall a b. (a -> b) -> [a] -> [b]
map Tx -> TxHash
txHash (Block -> [Tx]
blockTxns Block
b)
            , blockDataWeight :: Word32
blockDataWeight = if Network -> Bool
getSegWit Network
net then Word32
w else 0
            , blockDataSubsidy :: UnixTime
blockDataSubsidy = UnixTime
subsidy
            , blockDataFees :: UnixTime
blockDataFees = UnixTime
cb_out_val UnixTime -> UnixTime -> UnixTime
forall a. Num a => a -> a -> a
- UnixTime
subsidy
            , blockDataOutputs :: UnixTime
blockDataOutputs = UnixTime
ts_out_val
            }
    [BlockHash] -> Word32 -> m ()
forall (m :: * -> *). StoreWrite m => [BlockHash] -> Word32 -> m ()
setBlocksAtHeight
        ([BlockHash] -> [BlockHash]
forall a. Eq a => [a] -> [a]
nub (BlockHeader -> BlockHash
headerHash (BlockNode -> BlockHeader
nodeHeader BlockNode
n) BlockHash -> [BlockHash] -> [BlockHash]
forall a. a -> [a] -> [a]
: [BlockHash]
bs))
        (BlockNode -> Word32
nodeHeight BlockNode
n)
    BlockHash -> m ()
forall (m :: * -> *). StoreWrite m => BlockHash -> m ()
setBest (BlockHeader -> BlockHash
headerHash (BlockNode -> BlockHeader
nodeHeader BlockNode
n))
    BlockNode -> [Tx] -> m ()
forall (m :: * -> *). MonadImport m => BlockNode -> [Tx] -> m ()
importOrConfirm BlockNode
n (Block -> [Tx]
blockTxns Block
b)
    $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        "Finished importing transactions for: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex (BlockHeader -> BlockHash
headerHash (BlockNode -> BlockHeader
nodeHeader BlockNode
n))
  where
    cb_out_val :: UnixTime
cb_out_val =
        [UnixTime] -> UnixTime
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([UnixTime] -> UnixTime) -> [UnixTime] -> UnixTime
forall a b. (a -> b) -> a -> b
$ (TxOut -> UnixTime) -> [TxOut] -> [UnixTime]
forall a b. (a -> b) -> [a] -> [b]
map TxOut -> UnixTime
outValue ([TxOut] -> [UnixTime]) -> [TxOut] -> [UnixTime]
forall a b. (a -> b) -> a -> b
$ Tx -> [TxOut]
txOut (Tx -> [TxOut]) -> Tx -> [TxOut]
forall a b. (a -> b) -> a -> b
$ [Tx] -> Tx
forall a. [a] -> a
head ([Tx] -> Tx) -> [Tx] -> Tx
forall a b. (a -> b) -> a -> b
$ Block -> [Tx]
blockTxns Block
b
    ts_out_val :: UnixTime
ts_out_val =
        [UnixTime] -> UnixTime
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([UnixTime] -> UnixTime) -> [UnixTime] -> UnixTime
forall a b. (a -> b) -> a -> b
$ (Tx -> UnixTime) -> [Tx] -> [UnixTime]
forall a b. (a -> b) -> [a] -> [b]
map ([UnixTime] -> UnixTime
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([UnixTime] -> UnixTime) -> (Tx -> [UnixTime]) -> Tx -> UnixTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOut -> UnixTime) -> [TxOut] -> [UnixTime]
forall a b. (a -> b) -> [a] -> [b]
map TxOut -> UnixTime
outValue ([TxOut] -> [UnixTime]) -> (Tx -> [TxOut]) -> Tx -> [UnixTime]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx -> [TxOut]
txOut) ([Tx] -> [UnixTime]) -> [Tx] -> [UnixTime]
forall a b. (a -> b) -> a -> b
$ [Tx] -> [Tx]
forall a. [a] -> [a]
tail ([Tx] -> [Tx]) -> [Tx] -> [Tx]
forall a b. (a -> b) -> a -> b
$ Block -> [Tx]
blockTxns Block
b
    w :: Word32
w =
        let f :: Tx -> Tx
f t :: Tx
t = Tx
t {txWitness :: WitnessData
txWitness = []}
            b' :: Block
b' = Block
b {blockTxns :: [Tx]
blockTxns = (Tx -> Tx) -> [Tx] -> [Tx]
forall a b. (a -> b) -> [a] -> [b]
map Tx -> Tx
f (Block -> [Tx]
blockTxns Block
b)}
            x :: Int
x = ByteString -> Int
B.length (Block -> ByteString
forall a. Serialize a => a -> ByteString
encode Block
b)
            s :: Int
s = ByteString -> Int
B.length (Block -> ByteString
forall a. Serialize a => a -> ByteString
encode Block
b')
         in Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
* 3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x

checkNewTx :: MonadImport m => Tx -> m ()
checkNewTx :: Tx -> m ()
checkNewTx tx :: Tx
tx = do
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
unique_inputs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [TxIn] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Tx -> [TxIn]
txIn Tx
tx)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            "Transaction spends same output twice: "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
        ImportException -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
DuplicatePrevOutput
    [Maybe Unspent]
us <- Tx -> m [Maybe Unspent]
forall (m :: * -> *). StoreReadBase m => Tx -> m [Maybe Unspent]
getUnspentOutputs Tx
tx
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Maybe Unspent -> Bool) -> [Maybe Unspent] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe Unspent -> Bool
forall a. Maybe a -> Bool
isNothing [Maybe Unspent]
us) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            "Orphan: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
        ImportException -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
Orphan
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Tx -> Bool
isCoinbase Tx
tx) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            "Coinbase cannot be imported into mempool: "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
        ImportException -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
UnexpectedCoinbase
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([OutPoint] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Tx -> [OutPoint]
prevOuts Tx
tx) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [Maybe Unspent] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe Unspent]
us) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            "Orphan: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
        ImportException -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
Orphan
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UnixTime
outputs UnixTime -> UnixTime -> Bool
forall a. Ord a => a -> a -> Bool
> [Maybe Unspent] -> UnixTime
unspents [Maybe Unspent]
us) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            "Insufficient funds for tx: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
        ImportException -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
InsufficientFunds
  where
    unspents :: [Maybe Unspent] -> UnixTime
unspents = [UnixTime] -> UnixTime
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([UnixTime] -> UnixTime)
-> ([Maybe Unspent] -> [UnixTime]) -> [Maybe Unspent] -> UnixTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unspent -> UnixTime) -> [Unspent] -> [UnixTime]
forall a b. (a -> b) -> [a] -> [b]
map Unspent -> UnixTime
unspentAmount ([Unspent] -> [UnixTime])
-> ([Maybe Unspent] -> [Unspent]) -> [Maybe Unspent] -> [UnixTime]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Unspent] -> [Unspent]
forall a. [Maybe a] -> [a]
catMaybes
    outputs :: UnixTime
outputs = [UnixTime] -> UnixTime
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((TxOut -> UnixTime) -> [TxOut] -> [UnixTime]
forall a b. (a -> b) -> [a] -> [b]
map TxOut -> UnixTime
outValue (Tx -> [TxOut]
txOut Tx
tx))
    unique_inputs :: Int
unique_inputs = [OutPoint] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([OutPoint] -> [OutPoint]
forall a. (Eq a, Hashable a) => [a] -> [a]
nub' ((TxIn -> OutPoint) -> [TxIn] -> [OutPoint]
forall a b. (a -> b) -> [a] -> [b]
map TxIn -> OutPoint
prevOutput (Tx -> [TxIn]
txIn Tx
tx)))

getUnspentOutputs :: StoreReadBase m => Tx -> m [Maybe Unspent]
getUnspentOutputs :: Tx -> m [Maybe Unspent]
getUnspentOutputs tx :: Tx
tx = (OutPoint -> m (Maybe Unspent)) -> [OutPoint] -> m [Maybe Unspent]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM OutPoint -> m (Maybe Unspent)
forall (m :: * -> *).
StoreReadBase m =>
OutPoint -> m (Maybe Unspent)
getUnspent (Tx -> [OutPoint]
prevOuts Tx
tx)

prepareTxData :: Bool -> BlockRef -> Word64 -> Tx -> [Unspent] -> TxData
prepareTxData :: Bool -> BlockRef -> UnixTime -> Tx -> [Unspent] -> TxData
prepareTxData rbf :: Bool
rbf br :: BlockRef
br tt :: UnixTime
tt tx :: Tx
tx us :: [Unspent]
us =
    $WTxData :: BlockRef -> Tx -> IntMap Prev -> Bool -> Bool -> UnixTime -> TxData
TxData { txDataBlock :: BlockRef
txDataBlock = BlockRef
br
           , txData :: Tx
txData = Tx
tx
           , txDataPrevs :: IntMap Prev
txDataPrevs = IntMap Prev
ps
           , txDataDeleted :: Bool
txDataDeleted = Bool
False
           , txDataRBF :: Bool
txDataRBF = Bool
rbf
           , txDataTime :: UnixTime
txDataTime = UnixTime
tt
           }
  where
    mkprv :: Unspent -> Prev
mkprv u :: Unspent
u = ByteString -> UnixTime -> Prev
Prev (Unspent -> ByteString
unspentScript Unspent
u) (Unspent -> UnixTime
unspentAmount Unspent
u)
    ps :: IntMap Prev
ps = [(Int, Prev)] -> IntMap Prev
forall a. [(Int, a)] -> IntMap a
I.fromList ([(Int, Prev)] -> IntMap Prev) -> [(Int, Prev)] -> IntMap Prev
forall a b. (a -> b) -> a -> b
$ [Int] -> [Prev] -> [(Int, Prev)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0 ..] ([Prev] -> [(Int, Prev)]) -> [Prev] -> [(Int, Prev)]
forall a b. (a -> b) -> a -> b
$ (Unspent -> Prev) -> [Unspent] -> [Prev]
forall a b. (a -> b) -> [a] -> [b]
map Unspent -> Prev
mkprv [Unspent]
us

importTx
    :: MonadImport m
    => BlockRef
    -> Word64 -- ^ unix time
    -> Bool -- ^ RBF
    -> Tx
    -> m ()
importTx :: BlockRef -> UnixTime -> Bool -> Tx -> m ()
importTx br :: BlockRef
br tt :: UnixTime
tt rbf :: Bool
rbf tx :: Tx
tx = do
    [Maybe Unspent]
mus <- Tx -> m [Maybe Unspent]
forall (m :: * -> *). StoreReadBase m => Tx -> m [Maybe Unspent]
getUnspentOutputs Tx
tx
    [Unspent]
us <- [Maybe Unspent] -> (Maybe Unspent -> m Unspent) -> m [Unspent]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Maybe Unspent]
mus ((Maybe Unspent -> m Unspent) -> m [Unspent])
-> (Maybe Unspent -> m Unspent) -> m [Unspent]
forall a b. (a -> b) -> a -> b
$ \case
        Nothing -> do
            $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                "Attempted to import a tx missing UTXO: "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
            ImportException -> m Unspent
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
Orphan
        Just u :: Unspent
u -> Unspent -> m Unspent
forall (m :: * -> *) a. Monad m => a -> m a
return Unspent
u
    let td :: TxData
td = Bool -> BlockRef -> UnixTime -> Tx -> [Unspent] -> TxData
prepareTxData Bool
rbf BlockRef
br UnixTime
tt Tx
tx [Unspent]
us
    TxData -> m ()
forall (m :: * -> *). MonadImport m => TxData -> m ()
commitAddTx TxData
td

unConfirmTx :: MonadImport m => TxData -> m ()
unConfirmTx :: TxData -> m ()
unConfirmTx t :: TxData
t = TxData -> Maybe BlockRef -> m ()
forall (m :: * -> *).
MonadImport m =>
TxData -> Maybe BlockRef -> m ()
confTx TxData
t Maybe BlockRef
forall a. Maybe a
Nothing

confirmTx :: MonadImport m => TxData -> BlockRef -> m ()
confirmTx :: TxData -> BlockRef -> m ()
confirmTx t :: TxData
t br :: BlockRef
br = TxData -> Maybe BlockRef -> m ()
forall (m :: * -> *).
MonadImport m =>
TxData -> Maybe BlockRef -> m ()
confTx TxData
t (BlockRef -> Maybe BlockRef
forall a. a -> Maybe a
Just BlockRef
br)

replaceAddressTx :: MonadImport m => TxData -> BlockRef -> m ()
replaceAddressTx :: TxData -> BlockRef -> m ()
replaceAddressTx t :: TxData
t new :: BlockRef
new = [Address] -> (Address -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (TxData -> [Address]
txDataAddresses TxData
t) ((Address -> m ()) -> m ()) -> (Address -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \a :: Address
a -> do
    Address -> TxRef -> m ()
forall (m :: * -> *). StoreWrite m => Address -> TxRef -> m ()
deleteAddrTx
        Address
a
        $WTxRef :: BlockRef -> TxHash -> TxRef
TxRef { txRefBlock :: BlockRef
txRefBlock = TxData -> BlockRef
txDataBlock TxData
t
              , txRefHash :: TxHash
txRefHash = Tx -> TxHash
txHash (TxData -> Tx
txData TxData
t) }
    Address -> TxRef -> m ()
forall (m :: * -> *). StoreWrite m => Address -> TxRef -> m ()
insertAddrTx
        Address
a
        $WTxRef :: BlockRef -> TxHash -> TxRef
TxRef { txRefBlock :: BlockRef
txRefBlock = BlockRef
new
              , txRefHash :: TxHash
txRefHash = Tx -> TxHash
txHash (TxData -> Tx
txData TxData
t) }

adjustAddressOutput :: MonadImport m
                    => OutPoint -> TxOut -> BlockRef -> BlockRef -> m ()
adjustAddressOutput :: OutPoint -> TxOut -> BlockRef -> BlockRef -> m ()
adjustAddressOutput op :: OutPoint
op o :: TxOut
o old :: BlockRef
old new :: BlockRef
new = do
    let pk :: ByteString
pk = TxOut -> ByteString
scriptOutput TxOut
o
    OutPoint -> m (Maybe Unspent)
forall (m :: * -> *).
StoreReadBase m =>
OutPoint -> m (Maybe Unspent)
getUnspent OutPoint
op m (Maybe Unspent) -> (Maybe Unspent -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just u :: Unspent
u -> do
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Unspent -> BlockRef
unspentBlock Unspent
u BlockRef -> BlockRef -> Bool
forall a. Eq a => a -> a -> Bool
== BlockRef
old) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                String -> m ()
forall a. HasCallStack => String -> a
error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ "Existing unspent block bad for output: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> OutPoint -> String
forall a. Show a => a -> String
show OutPoint
op
            ByteString -> m ()
forall (m :: * -> *).
(StoreWrite m, MonadError ImportException m, MonadLoggerIO m,
 StoreReadBase m) =>
ByteString -> m ()
replace_unspent ByteString
pk
  where
    replace_unspent :: ByteString -> m ()
replace_unspent pk :: ByteString
pk = do
        let ma :: Maybe Address
ma = Either String Address -> Maybe Address
forall a b. Either a b -> Maybe b
eitherToMaybe (ByteString -> Either String Address
scriptToAddressBS ByteString
pk)
        OutPoint -> m ()
forall (m :: * -> *). StoreWrite m => OutPoint -> m ()
deleteUnspent OutPoint
op
        Unspent -> m ()
forall (m :: * -> *). StoreWrite m => Unspent -> m ()
insertUnspent
            $WUnspent :: BlockRef
-> OutPoint -> UnixTime -> ByteString -> Maybe Address -> Unspent
Unspent
                { unspentBlock :: BlockRef
unspentBlock = BlockRef
new
                , unspentPoint :: OutPoint
unspentPoint = OutPoint
op
                , unspentAmount :: UnixTime
unspentAmount = TxOut -> UnixTime
outValue TxOut
o
                , unspentScript :: ByteString
unspentScript = ByteString
pk
                , unspentAddress :: Maybe Address
unspentAddress = Maybe Address
ma
                }
        Maybe Address -> (Address -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Address
ma ((Address -> m ()) -> m ()) -> (Address -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Address -> m ()
forall (m :: * -> *).
(StoreWrite m, MonadError ImportException m, MonadLoggerIO m,
 StoreReadBase m) =>
ByteString -> Address -> m ()
replace_addr_unspent ByteString
pk
    replace_addr_unspent :: ByteString -> Address -> m ()
replace_addr_unspent pk :: ByteString
pk a :: Address
a = do
        Address -> Unspent -> m ()
forall (m :: * -> *). StoreWrite m => Address -> Unspent -> m ()
deleteAddrUnspent
            Address
a
            $WUnspent :: BlockRef
-> OutPoint -> UnixTime -> ByteString -> Maybe Address -> Unspent
Unspent
                { unspentBlock :: BlockRef
unspentBlock = BlockRef
old
                , unspentPoint :: OutPoint
unspentPoint = OutPoint
op
                , unspentAmount :: UnixTime
unspentAmount = TxOut -> UnixTime
outValue TxOut
o
                , unspentScript :: ByteString
unspentScript = ByteString
pk
                , unspentAddress :: Maybe Address
unspentAddress = Address -> Maybe Address
forall a. a -> Maybe a
Just Address
a
                }
        Address -> Unspent -> m ()
forall (m :: * -> *). StoreWrite m => Address -> Unspent -> m ()
insertAddrUnspent
            Address
a
            $WUnspent :: BlockRef
-> OutPoint -> UnixTime -> ByteString -> Maybe Address -> Unspent
Unspent
                { unspentBlock :: BlockRef
unspentBlock = BlockRef
new
                , unspentPoint :: OutPoint
unspentPoint = OutPoint
op
                , unspentAmount :: UnixTime
unspentAmount = TxOut -> UnixTime
outValue TxOut
o
                , unspentScript :: ByteString
unspentScript = ByteString
pk
                , unspentAddress :: Maybe Address
unspentAddress = Address -> Maybe Address
forall a. a -> Maybe a
Just Address
a
                }
        Bool -> Address -> UnixTime -> m ()
forall (m :: * -> *).
MonadImport m =>
Bool -> Address -> UnixTime -> m ()
decreaseBalance (BlockRef -> Bool
confirmed BlockRef
old) Address
a (TxOut -> UnixTime
outValue TxOut
o)
        Bool -> Address -> UnixTime -> m ()
forall (m :: * -> *).
MonadImport m =>
Bool -> Address -> UnixTime -> m ()
increaseBalance (BlockRef -> Bool
confirmed BlockRef
new) Address
a (TxOut -> UnixTime
outValue TxOut
o)

confTx :: MonadImport m => TxData -> Maybe BlockRef -> m ()
confTx :: TxData -> Maybe BlockRef -> m ()
confTx t :: TxData
t mbr :: Maybe BlockRef
mbr = do
    TxData -> BlockRef -> m ()
forall (m :: * -> *). MonadImport m => TxData -> BlockRef -> m ()
replaceAddressTx TxData
t BlockRef
new
    [(Word32, TxOut)] -> ((Word32, TxOut) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Word32] -> [TxOut] -> [(Word32, TxOut)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0 ..] (Tx -> [TxOut]
txOut (TxData -> Tx
txData TxData
t))) (((Word32, TxOut) -> m ()) -> m ())
-> ((Word32, TxOut) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(n :: Word32
n, o :: TxOut
o) -> do
        let op :: OutPoint
op = TxHash -> Word32 -> OutPoint
OutPoint (Tx -> TxHash
txHash (TxData -> Tx
txData TxData
t)) Word32
n
        OutPoint -> TxOut -> BlockRef -> BlockRef -> m ()
forall (m :: * -> *).
MonadImport m =>
OutPoint -> TxOut -> BlockRef -> BlockRef -> m ()
adjustAddressOutput OutPoint
op TxOut
o BlockRef
old BlockRef
new
    Bool
rbf <- BlockRef -> Tx -> m Bool
forall (m :: * -> *). StoreReadBase m => BlockRef -> Tx -> m Bool
isRBF BlockRef
new (TxData -> Tx
txData TxData
t)
    let td :: TxData
td = TxData
t { txDataBlock :: BlockRef
txDataBlock = BlockRef
new, txDataRBF :: Bool
txDataRBF = Bool
rbf }
    TxData -> m ()
forall (m :: * -> *). StoreWrite m => TxData -> m ()
insertTx TxData
td
    TxData -> m ()
forall (m :: * -> *). MonadImport m => TxData -> m ()
updateMempool TxData
td
  where
    new :: BlockRef
new = BlockRef -> Maybe BlockRef -> BlockRef
forall a. a -> Maybe a -> a
fromMaybe (UnixTime -> BlockRef
MemRef (TxData -> UnixTime
txDataTime TxData
t)) Maybe BlockRef
mbr
    old :: BlockRef
old = TxData -> BlockRef
txDataBlock TxData
t

freeOutputs
    :: MonadImport m
    => Bool -- ^ only delete transaction if unconfirmed
    -> Bool -- ^ only delete RBF
    -> Tx
    -> m ()
freeOutputs :: Bool -> Bool -> Tx -> m ()
freeOutputs memonly :: Bool
memonly rbfcheck :: Bool
rbfcheck tx :: Tx
tx =
    [OutPoint] -> (OutPoint -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Tx -> [OutPoint]
prevOuts Tx
tx) ((OutPoint -> m ()) -> m ()) -> (OutPoint -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \op :: OutPoint
op ->
    OutPoint -> m (Maybe Unspent)
forall (m :: * -> *).
StoreReadBase m =>
OutPoint -> m (Maybe Unspent)
getUnspent OutPoint
op m (Maybe Unspent) -> (Maybe Unspent -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \u :: Maybe Unspent
u -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Unspent -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Unspent
u) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    OutPoint -> m (Maybe Spender)
forall (m :: * -> *).
StoreReadBase m =>
OutPoint -> m (Maybe Spender)
getSpender OutPoint
op m (Maybe Spender) -> (Maybe Spender -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \p :: Maybe Spender
p -> Maybe Spender -> (Spender -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Spender
p ((Spender -> m ()) -> m ()) -> (Spender -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \s :: Spender
s ->
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Spender -> TxHash
spenderHash Spender
s TxHash -> TxHash -> Bool
forall a. Eq a => a -> a -> Bool
== Tx -> TxHash
txHash Tx
tx) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    Bool -> Bool -> TxHash -> m ()
forall (m :: * -> *).
MonadImport m =>
Bool -> Bool -> TxHash -> m ()
deleteTx Bool
memonly Bool
rbfcheck (Spender -> TxHash
spenderHash Spender
s)

deleteConfirmedTx :: MonadImport m => TxHash -> m ()
deleteConfirmedTx :: TxHash -> m ()
deleteConfirmedTx = Bool -> Bool -> TxHash -> m ()
forall (m :: * -> *).
MonadImport m =>
Bool -> Bool -> TxHash -> m ()
deleteTx Bool
False Bool
False

deleteUnconfirmedTx :: MonadImport m => Bool -> TxHash -> m ()
deleteUnconfirmedTx :: Bool -> TxHash -> m ()
deleteUnconfirmedTx rbfcheck :: Bool
rbfcheck th :: TxHash
th =
    TxHash -> m (Maybe TxData)
forall (m :: * -> *). StoreReadBase m => TxHash -> m (Maybe TxData)
getActiveTxData TxHash
th m (Maybe TxData) -> (Maybe TxData -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just _ -> Bool -> Bool -> TxHash -> m ()
forall (m :: * -> *).
MonadImport m =>
Bool -> Bool -> TxHash -> m ()
deleteTx Bool
True Bool
rbfcheck TxHash
th
        Nothing -> $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                   "Not found or already deleted: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
th

deleteTx :: MonadImport m
         => Bool -- ^ only delete transaction if unconfirmed
         -> Bool -- ^ only delete RBF
         -> TxHash
         -> m ()
deleteTx :: Bool -> Bool -> TxHash -> m ()
deleteTx memonly :: Bool
memonly rbfcheck :: Bool
rbfcheck th :: TxHash
th =
    Bool -> Bool -> TxHash -> m [Tx]
forall (m :: * -> *).
MonadImport m =>
Bool -> Bool -> TxHash -> m [Tx]
getChain Bool
memonly Bool
rbfcheck TxHash
th m [Tx] -> ([Tx] -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    (Tx -> m ()) -> [Tx] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TxHash -> m ()
forall (m :: * -> *). MonadImport m => TxHash -> m ()
deleteSingleTx (TxHash -> m ()) -> (Tx -> TxHash) -> Tx -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx -> TxHash
txHash)

getChain :: MonadImport m
         => Bool -- ^ only delete transaction if unconfirmed
         -> Bool -- ^ only delete RBF
         -> TxHash
         -> m [Tx]
getChain :: Bool -> Bool -> TxHash -> m [Tx]
getChain memonly :: Bool
memonly rbfcheck :: Bool
rbfcheck th :: TxHash
th =
    ([Tx] -> [Tx]) -> m [Tx] -> m [Tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Tx] -> [Tx]
sort_clean (m [Tx] -> m [Tx]) -> m [Tx] -> m [Tx]
forall a b. (a -> b) -> a -> b
$
    TxHash -> m (Maybe TxData)
forall (m :: * -> *). StoreReadBase m => TxHash -> m (Maybe TxData)
getActiveTxData TxHash
th m (Maybe TxData) -> (Maybe TxData -> m [Tx]) -> m [Tx]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Nothing -> do
            $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                "Transaction not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
th
            ImportException -> m [Tx]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
TxNotFound
        Just td :: TxData
td
          | Bool
memonly Bool -> Bool -> Bool
&& BlockRef -> Bool
confirmed (TxData -> BlockRef
txDataBlock TxData
td) -> do
            $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                "Transaction already confirmed: "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
th
            ImportException -> m [Tx]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
TxConfirmed
          | Bool
rbfcheck ->
            BlockRef -> Tx -> m Bool
forall (m :: * -> *). StoreReadBase m => BlockRef -> Tx -> m Bool
isRBF (TxData -> BlockRef
txDataBlock TxData
td) (TxData -> Tx
txData TxData
td) m Bool -> (Bool -> m [Tx]) -> m [Tx]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                True -> TxData -> m [Tx]
forall (m :: * -> *).
(StoreReadBase m, MonadError ImportException m, MonadLoggerIO m,
 StoreWrite m) =>
TxData -> m [Tx]
go TxData
td
                False -> do
                    $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                        "Double-spending transaction: "
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
th
                    ImportException -> m [Tx]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
DoubleSpend
          | Bool
otherwise -> TxData -> m [Tx]
forall (m :: * -> *).
(StoreReadBase m, MonadError ImportException m, MonadLoggerIO m,
 StoreWrite m) =>
TxData -> m [Tx]
go TxData
td
  where
    sort_clean :: [Tx] -> [Tx]
sort_clean = [Tx] -> [Tx]
forall a. [a] -> [a]
reverse ([Tx] -> [Tx]) -> ([Tx] -> [Tx]) -> [Tx] -> [Tx]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Word32, Tx) -> Tx) -> [(Word32, Tx)] -> [Tx]
forall a b. (a -> b) -> [a] -> [b]
map (Word32, Tx) -> Tx
forall a b. (a, b) -> b
snd ([(Word32, Tx)] -> [Tx])
-> ([Tx] -> [(Word32, Tx)]) -> [Tx] -> [Tx]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tx] -> [(Word32, Tx)]
sortTxs ([Tx] -> [(Word32, Tx)])
-> ([Tx] -> [Tx]) -> [Tx] -> [(Word32, Tx)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tx] -> [Tx]
forall a. (Eq a, Hashable a) => [a] -> [a]
nub'
    go :: TxData -> m [Tx]
go td :: TxData
td = do
        let tx :: Tx
tx = TxData -> Tx
txData TxData
td
        [TxHash]
ss <- [TxHash] -> [TxHash]
forall a. (Eq a, Hashable a) => [a] -> [a]
nub' ([TxHash] -> [TxHash])
-> (IntMap Spender -> [TxHash]) -> IntMap Spender -> [TxHash]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Spender -> TxHash) -> [Spender] -> [TxHash]
forall a b. (a -> b) -> [a] -> [b]
map Spender -> TxHash
spenderHash ([Spender] -> [TxHash])
-> (IntMap Spender -> [Spender]) -> IntMap Spender -> [TxHash]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap Spender -> [Spender]
forall a. IntMap a -> [a]
I.elems (IntMap Spender -> [TxHash]) -> m (IntMap Spender) -> m [TxHash]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxHash -> m (IntMap Spender)
forall (m :: * -> *).
StoreReadBase m =>
TxHash -> m (IntMap Spender)
getSpenders TxHash
th
        [Tx]
xs <- [[Tx]] -> [Tx]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Tx]] -> [Tx]) -> m [[Tx]] -> m [Tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TxHash -> m [Tx]) -> [TxHash] -> m [[Tx]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> Bool -> TxHash -> m [Tx]
forall (m :: * -> *).
MonadImport m =>
Bool -> Bool -> TxHash -> m [Tx]
getChain Bool
memonly Bool
rbfcheck) [TxHash]
ss
        [Tx] -> m [Tx]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Tx] -> m [Tx]) -> [Tx] -> m [Tx]
forall a b. (a -> b) -> a -> b
$ Tx
tx Tx -> [Tx] -> [Tx]
forall a. a -> [a] -> [a]
: [Tx]
xs

deleteSingleTx :: MonadImport m => TxHash -> m ()
deleteSingleTx :: TxHash -> m ()
deleteSingleTx th :: TxHash
th =
    TxHash -> m (Maybe TxData)
forall (m :: * -> *). StoreReadBase m => TxHash -> m (Maybe TxData)
getActiveTxData TxHash
th m (Maybe TxData) -> (Maybe TxData -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Nothing -> do
            $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                "Already deleted: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
th
            ImportException -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
TxNotFound
        Just td :: TxData
td -> do
            $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                "Deleting tx: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
th
            TxHash -> m (IntMap Spender)
forall (m :: * -> *).
StoreReadBase m =>
TxHash -> m (IntMap Spender)
getSpenders TxHash
th m (IntMap Spender) -> (IntMap Spender -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                m :: IntMap Spender
m | IntMap Spender -> Bool
forall a. IntMap a -> Bool
I.null IntMap Spender
m -> TxData -> m ()
forall (m :: * -> *). MonadImport m => TxData -> m ()
commitDelTx TxData
td
                  | Bool
otherwise -> do
                        $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logErrorS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                            "Tried to delete spent tx: "
                            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
th
                        ImportException -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
TxSpent

commitDelTx :: MonadImport m => TxData -> m ()
commitDelTx :: TxData -> m ()
commitDelTx = Bool -> TxData -> m ()
forall (m :: * -> *). MonadImport m => Bool -> TxData -> m ()
commitModTx Bool
False

commitAddTx :: MonadImport m => TxData -> m ()
commitAddTx :: TxData -> m ()
commitAddTx = Bool -> TxData -> m ()
forall (m :: * -> *). MonadImport m => Bool -> TxData -> m ()
commitModTx Bool
True

commitModTx :: MonadImport m => Bool -> TxData -> m ()
commitModTx :: Bool -> TxData -> m ()
commitModTx add :: Bool
add tx_data :: TxData
tx_data = do
    (Address -> m ()) -> [Address] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Address -> m ()
forall (m :: * -> *).
(StoreWrite m, MonadError ImportException m, MonadLoggerIO m,
 StoreReadBase m) =>
Address -> m ()
mod_addr_tx (TxData -> [Address]
txDataAddresses TxData
td)
    m ()
mod_outputs
    m ()
mod_unspent
    TxData -> m ()
forall (m :: * -> *). StoreWrite m => TxData -> m ()
insertTx TxData
td
    TxData -> m ()
forall (m :: * -> *). MonadImport m => TxData -> m ()
updateMempool TxData
td
  where
    tx :: Tx
tx = TxData -> Tx
txData TxData
td
    br :: BlockRef
br = TxData -> BlockRef
txDataBlock TxData
td
    td :: TxData
td = TxData
tx_data { txDataDeleted :: Bool
txDataDeleted = Bool -> Bool
not Bool
add }
    tx_ref :: TxRef
tx_ref = BlockRef -> TxHash -> TxRef
TxRef BlockRef
br (Tx -> TxHash
txHash Tx
tx)
    mod_addr_tx :: Address -> m ()
mod_addr_tx a :: Address
a
      | Bool
add = do
            Address -> TxRef -> m ()
forall (m :: * -> *). StoreWrite m => Address -> TxRef -> m ()
insertAddrTx Address
a TxRef
tx_ref
            Bool -> Address -> m ()
forall (m :: * -> *). MonadImport m => Bool -> Address -> m ()
modAddressCount Bool
add Address
a
      | Bool
otherwise = do
            Address -> TxRef -> m ()
forall (m :: * -> *). StoreWrite m => Address -> TxRef -> m ()
deleteAddrTx Address
a TxRef
tx_ref
            Bool -> Address -> m ()
forall (m :: * -> *). MonadImport m => Bool -> Address -> m ()
modAddressCount Bool
add Address
a
    mod_unspent :: m ()
mod_unspent
      | Bool
add = Tx -> m ()
forall (m :: * -> *). MonadImport m => Tx -> m ()
spendOutputs Tx
tx
      | Bool
otherwise = Tx -> m ()
forall (m :: * -> *). MonadImport m => Tx -> m ()
unspendOutputs Tx
tx
    mod_outputs :: m ()
mod_outputs
      | Bool
add = BlockRef -> Tx -> m ()
forall (m :: * -> *). MonadImport m => BlockRef -> Tx -> m ()
addOutputs BlockRef
br Tx
tx
      | Bool
otherwise = BlockRef -> Tx -> m ()
forall (m :: * -> *). MonadImport m => BlockRef -> Tx -> m ()
delOutputs BlockRef
br Tx
tx

updateMempool :: MonadImport m => TxData -> m ()
updateMempool :: TxData -> m ()
updateMempool td :: TxData
td@TxData{txDataDeleted :: TxData -> Bool
txDataDeleted = Bool
True} =
    TxHash -> m ()
forall (m :: * -> *). StoreWrite m => TxHash -> m ()
deleteFromMempool (Tx -> TxHash
txHash (TxData -> Tx
txData TxData
td))
updateMempool td :: TxData
td@TxData{txDataDeleted :: TxData -> Bool
txDataDeleted = Bool
False, txDataBlock :: TxData -> BlockRef
txDataBlock = MemRef t :: UnixTime
t} =
    TxHash -> UnixTime -> m ()
forall (m :: * -> *). StoreWrite m => TxHash -> UnixTime -> m ()
addToMempool (Tx -> TxHash
txHash (TxData -> Tx
txData TxData
td)) UnixTime
t
updateMempool td :: TxData
td@TxData{txDataBlock :: TxData -> BlockRef
txDataBlock = BlockRef{}} =
    TxHash -> m ()
forall (m :: * -> *). StoreWrite m => TxHash -> m ()
deleteFromMempool (Tx -> TxHash
txHash (TxData -> Tx
txData TxData
td))

spendOutputs :: MonadImport m => Tx -> m ()
spendOutputs :: Tx -> m ()
spendOutputs tx :: Tx
tx =
    (Word32 -> OutPoint -> m ()) -> [Word32] -> [OutPoint] -> m ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (TxHash -> Word32 -> OutPoint -> m ()
forall (m :: * -> *).
MonadImport m =>
TxHash -> Word32 -> OutPoint -> m ()
spendOutput (Tx -> TxHash
txHash Tx
tx)) [0 ..] (Tx -> [OutPoint]
prevOuts Tx
tx)

addOutputs :: MonadImport m => BlockRef -> Tx -> m ()
addOutputs :: BlockRef -> Tx -> m ()
addOutputs br :: BlockRef
br tx :: Tx
tx =
    (Word32 -> TxOut -> m ()) -> [Word32] -> [TxOut] -> m ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (BlockRef -> OutPoint -> TxOut -> m ()
forall (m :: * -> *).
MonadImport m =>
BlockRef -> OutPoint -> TxOut -> m ()
addOutput BlockRef
br (OutPoint -> TxOut -> m ())
-> (Word32 -> OutPoint) -> Word32 -> TxOut -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxHash -> Word32 -> OutPoint
OutPoint (Tx -> TxHash
txHash Tx
tx)) [0 ..] (Tx -> [TxOut]
txOut Tx
tx)

isRBF :: StoreReadBase m
      => BlockRef
      -> Tx
      -> m Bool
isRBF :: BlockRef -> Tx -> m Bool
isRBF br :: BlockRef
br tx :: Tx
tx
  | BlockRef -> Bool
confirmed BlockRef
br = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  | Bool
otherwise =
    m Network
forall (m :: * -> *). StoreReadBase m => m Network
getNetwork m Network -> (Network -> m Bool) -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \net :: Network
net ->
        if Network -> Bool
getReplaceByFee Network
net
        then m Bool
go
        else Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  where
    go :: m Bool
go | (TxIn -> Bool) -> [TxIn] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< 0xffffffff Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- 1) (Word32 -> Bool) -> (TxIn -> Word32) -> TxIn -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxIn -> Word32
txInSequence) (Tx -> [TxIn]
txIn Tx
tx) = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
       | Bool
otherwise = m Bool
carry_on
    carry_on :: m Bool
carry_on =
        let hs :: [TxHash]
hs = [TxHash] -> [TxHash]
forall a. (Eq a, Hashable a) => [a] -> [a]
nub' ([TxHash] -> [TxHash]) -> [TxHash] -> [TxHash]
forall a b. (a -> b) -> a -> b
$ (TxIn -> TxHash) -> [TxIn] -> [TxHash]
forall a b. (a -> b) -> [a] -> [b]
map (OutPoint -> TxHash
outPointHash (OutPoint -> TxHash) -> (TxIn -> OutPoint) -> TxIn -> TxHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxIn -> OutPoint
prevOutput) (Tx -> [TxIn]
txIn Tx
tx)
            ck :: [TxHash] -> m Bool
ck [] = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            ck (h :: TxHash
h : hs' :: [TxHash]
hs') =
                TxHash -> m (Maybe TxData)
forall (m :: * -> *). StoreReadBase m => TxHash -> m (Maybe TxData)
getActiveTxData TxHash
h m (Maybe TxData) -> (Maybe TxData -> m Bool) -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Nothing -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                    Just t :: TxData
t | BlockRef -> Bool
confirmed (TxData -> BlockRef
txDataBlock TxData
t) -> [TxHash] -> m Bool
ck [TxHash]
hs'
                           | TxData -> Bool
txDataRBF TxData
t -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                           | Bool
otherwise -> [TxHash] -> m Bool
ck [TxHash]
hs'
         in [TxHash] -> m Bool
forall (m :: * -> *). StoreReadBase m => [TxHash] -> m Bool
ck [TxHash]
hs

addOutput :: MonadImport m => BlockRef -> OutPoint -> TxOut -> m ()
addOutput :: BlockRef -> OutPoint -> TxOut -> m ()
addOutput = Bool -> BlockRef -> OutPoint -> TxOut -> m ()
forall (m :: * -> *).
MonadImport m =>
Bool -> BlockRef -> OutPoint -> TxOut -> m ()
modOutput Bool
True

delOutput :: MonadImport m => BlockRef -> OutPoint -> TxOut -> m ()
delOutput :: BlockRef -> OutPoint -> TxOut -> m ()
delOutput = Bool -> BlockRef -> OutPoint -> TxOut -> m ()
forall (m :: * -> *).
MonadImport m =>
Bool -> BlockRef -> OutPoint -> TxOut -> m ()
modOutput Bool
False

modOutput :: MonadImport m => Bool -> BlockRef -> OutPoint -> TxOut -> m ()
modOutput :: Bool -> BlockRef -> OutPoint -> TxOut -> m ()
modOutput add :: Bool
add br :: BlockRef
br op :: OutPoint
op o :: TxOut
o = do
    m ()
mod_unspent
    Maybe Address -> (Address -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Address
ma ((Address -> m ()) -> m ()) -> (Address -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \a :: Address
a -> do
        Address -> Unspent -> m ()
mod_addr_unspent Address
a Unspent
u
        Bool -> Bool -> Address -> UnixTime -> m ()
forall (m :: * -> *).
MonadImport m =>
Bool -> Bool -> Address -> UnixTime -> m ()
modBalance (BlockRef -> Bool
confirmed BlockRef
br) Bool
add Address
a (TxOut -> UnixTime
outValue TxOut
o)
        Address -> (UnixTime -> UnixTime) -> m ()
forall (m :: * -> *).
MonadImport m =>
Address -> (UnixTime -> UnixTime) -> m ()
modifyReceived Address
a UnixTime -> UnixTime
v
  where
    v :: UnixTime -> UnixTime
v | Bool
add = (UnixTime -> UnixTime -> UnixTime
forall a. Num a => a -> a -> a
+ TxOut -> UnixTime
outValue TxOut
o)
      | Bool
otherwise = UnixTime -> UnixTime -> UnixTime
forall a. Num a => a -> a -> a
subtract (TxOut -> UnixTime
outValue TxOut
o)
    ma :: Maybe Address
ma = Either String Address -> Maybe Address
forall a b. Either a b -> Maybe b
eitherToMaybe (ByteString -> Either String Address
scriptToAddressBS (TxOut -> ByteString
scriptOutput TxOut
o))
    u :: Unspent
u = $WUnspent :: BlockRef
-> OutPoint -> UnixTime -> ByteString -> Maybe Address -> Unspent
Unspent { unspentScript :: ByteString
unspentScript = TxOut -> ByteString
scriptOutput TxOut
o
                , unspentBlock :: BlockRef
unspentBlock = BlockRef
br
                , unspentPoint :: OutPoint
unspentPoint = OutPoint
op
                , unspentAmount :: UnixTime
unspentAmount = TxOut -> UnixTime
outValue TxOut
o
                , unspentAddress :: Maybe Address
unspentAddress = Maybe Address
ma
                }
    mod_unspent :: m ()
mod_unspent | Bool
add = Unspent -> m ()
forall (m :: * -> *). StoreWrite m => Unspent -> m ()
insertUnspent Unspent
u
                | Bool
otherwise = OutPoint -> m ()
forall (m :: * -> *). StoreWrite m => OutPoint -> m ()
deleteUnspent OutPoint
op
    mod_addr_unspent :: Address -> Unspent -> m ()
mod_addr_unspent | Bool
add = Address -> Unspent -> m ()
forall (m :: * -> *). StoreWrite m => Address -> Unspent -> m ()
insertAddrUnspent
                     | Bool
otherwise = Address -> Unspent -> m ()
forall (m :: * -> *). StoreWrite m => Address -> Unspent -> m ()
deleteAddrUnspent

delOutputs :: MonadImport m => BlockRef -> Tx -> m ()
delOutputs :: BlockRef -> Tx -> m ()
delOutputs br :: BlockRef
br tx :: Tx
tx =
    [(Word32, TxOut)] -> ((Word32, TxOut) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Word32] -> [TxOut] -> [(Word32, TxOut)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] (Tx -> [TxOut]
txOut Tx
tx)) (((Word32, TxOut) -> m ()) -> m ())
-> ((Word32, TxOut) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(i :: Word32
i, o :: TxOut
o) -> do
        let op :: OutPoint
op = TxHash -> Word32 -> OutPoint
OutPoint (Tx -> TxHash
txHash Tx
tx) Word32
i
        BlockRef -> OutPoint -> TxOut -> m ()
forall (m :: * -> *).
MonadImport m =>
BlockRef -> OutPoint -> TxOut -> m ()
delOutput BlockRef
br OutPoint
op TxOut
o

getImportTxData :: MonadImport m => TxHash -> m TxData
getImportTxData :: TxHash -> m TxData
getImportTxData th :: TxHash
th =
    TxHash -> m (Maybe TxData)
forall (m :: * -> *). StoreReadBase m => TxHash -> m (Maybe TxData)
getActiveTxData TxHash
th m (Maybe TxData) -> (Maybe TxData -> m TxData) -> m TxData
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Nothing -> do
            $(Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logDebugS) "BlockStore" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ "Tx not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
th
            ImportException -> m TxData
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
TxNotFound
        Just d :: TxData
d -> TxData -> m TxData
forall (m :: * -> *) a. Monad m => a -> m a
return TxData
d

getTxOut :: Word32 -> Tx -> Maybe TxOut
getTxOut :: Word32 -> Tx -> Maybe TxOut
getTxOut i :: Word32
i tx :: Tx
tx = do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [TxOut] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Tx -> [TxOut]
txOut Tx
tx))
    TxOut -> Maybe TxOut
forall (m :: * -> *) a. Monad m => a -> m a
return (TxOut -> Maybe TxOut) -> TxOut -> Maybe TxOut
forall a b. (a -> b) -> a -> b
$ Tx -> [TxOut]
txOut Tx
tx [TxOut] -> Int -> TxOut
forall a. [a] -> Int -> a
!! Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
i

spendOutput :: MonadImport m => TxHash -> Word32 -> OutPoint -> m ()
spendOutput :: TxHash -> Word32 -> OutPoint -> m ()
spendOutput th :: TxHash
th ix :: Word32
ix op :: OutPoint
op = do
    Unspent
u <- OutPoint -> m (Maybe Unspent)
forall (m :: * -> *).
StoreReadBase m =>
OutPoint -> m (Maybe Unspent)
getUnspent OutPoint
op m (Maybe Unspent) -> (Maybe Unspent -> m Unspent) -> m Unspent
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just u :: Unspent
u  -> Unspent -> m Unspent
forall (m :: * -> *) a. Monad m => a -> m a
return Unspent
u
        Nothing -> String -> m Unspent
forall a. HasCallStack => String -> a
error (String -> m Unspent) -> String -> m Unspent
forall a b. (a -> b) -> a -> b
$ "Could not find UTXO to spend: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> OutPoint -> String
forall a. Show a => a -> String
show OutPoint
op
    OutPoint -> m ()
forall (m :: * -> *). StoreWrite m => OutPoint -> m ()
deleteUnspent OutPoint
op
    OutPoint -> Spender -> m ()
forall (m :: * -> *). StoreWrite m => OutPoint -> Spender -> m ()
insertSpender OutPoint
op (TxHash -> Word32 -> Spender
Spender TxHash
th Word32
ix)
    let pk :: ByteString
pk = Unspent -> ByteString
unspentScript Unspent
u
    Either String Address -> (Address -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ByteString -> Either String Address
scriptToAddressBS ByteString
pk) ((Address -> m ()) -> m ()) -> (Address -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \a :: Address
a -> do
        Bool -> Address -> UnixTime -> m ()
forall (m :: * -> *).
MonadImport m =>
Bool -> Address -> UnixTime -> m ()
decreaseBalance
            (BlockRef -> Bool
confirmed (Unspent -> BlockRef
unspentBlock Unspent
u))
            Address
a
            (Unspent -> UnixTime
unspentAmount Unspent
u)
        Address -> Unspent -> m ()
forall (m :: * -> *). StoreWrite m => Address -> Unspent -> m ()
deleteAddrUnspent Address
a Unspent
u

unspendOutputs :: MonadImport m => Tx -> m ()
unspendOutputs :: Tx -> m ()
unspendOutputs = (OutPoint -> m ()) -> [OutPoint] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ OutPoint -> m ()
forall (m :: * -> *). MonadImport m => OutPoint -> m ()
unspendOutput ([OutPoint] -> m ()) -> (Tx -> [OutPoint]) -> Tx -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx -> [OutPoint]
prevOuts

unspendOutput :: MonadImport m => OutPoint -> m ()
unspendOutput :: OutPoint -> m ()
unspendOutput op :: OutPoint
op = do
    TxData
t <- TxHash -> m (Maybe TxData)
forall (m :: * -> *). StoreReadBase m => TxHash -> m (Maybe TxData)
getActiveTxData (OutPoint -> TxHash
outPointHash OutPoint
op) m (Maybe TxData) -> (Maybe TxData -> m TxData) -> m TxData
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Nothing -> String -> m TxData
forall a. HasCallStack => String -> a
error (String -> m TxData) -> String -> m TxData
forall a b. (a -> b) -> a -> b
$ "Could not find tx data: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TxHash -> String
forall a. Show a => a -> String
show (OutPoint -> TxHash
outPointHash OutPoint
op)
        Just t :: TxData
t  -> TxData -> m TxData
forall (m :: * -> *) a. Monad m => a -> m a
return TxData
t
    let o :: TxOut
o = TxOut -> Maybe TxOut -> TxOut
forall a. a -> Maybe a -> a
fromMaybe
            (String -> TxOut
forall a. HasCallStack => String -> a
error ("Could not find output: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> OutPoint -> String
forall a. Show a => a -> String
show OutPoint
op))
            (Word32 -> Tx -> Maybe TxOut
getTxOut (OutPoint -> Word32
outPointIndex OutPoint
op) (TxData -> Tx
txData TxData
t))
        m :: Maybe Address
m = Either String Address -> Maybe Address
forall a b. Either a b -> Maybe b
eitherToMaybe (ByteString -> Either String Address
scriptToAddressBS (TxOut -> ByteString
scriptOutput TxOut
o))
        u :: Unspent
u = $WUnspent :: BlockRef
-> OutPoint -> UnixTime -> ByteString -> Maybe Address -> Unspent
Unspent { unspentAmount :: UnixTime
unspentAmount = TxOut -> UnixTime
outValue TxOut
o
                    , unspentBlock :: BlockRef
unspentBlock = TxData -> BlockRef
txDataBlock TxData
t
                    , unspentScript :: ByteString
unspentScript = TxOut -> ByteString
scriptOutput TxOut
o
                    , unspentPoint :: OutPoint
unspentPoint = OutPoint
op
                    , unspentAddress :: Maybe Address
unspentAddress = Maybe Address
m
                    }
    OutPoint -> m ()
forall (m :: * -> *). StoreWrite m => OutPoint -> m ()
deleteSpender OutPoint
op
    Unspent -> m ()
forall (m :: * -> *). StoreWrite m => Unspent -> m ()
insertUnspent Unspent
u
    Maybe Address -> (Address -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Address
m ((Address -> m ()) -> m ()) -> (Address -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \a :: Address
a -> do
        Address -> Unspent -> m ()
forall (m :: * -> *). StoreWrite m => Address -> Unspent -> m ()
insertAddrUnspent Address
a Unspent
u
        Bool -> Address -> UnixTime -> m ()
forall (m :: * -> *).
MonadImport m =>
Bool -> Address -> UnixTime -> m ()
increaseBalance (BlockRef -> Bool
confirmed (Unspent -> BlockRef
unspentBlock Unspent
u)) Address
a (TxOut -> UnixTime
outValue TxOut
o)

modifyReceived :: MonadImport m => Address -> (Word64 -> Word64) -> m ()
modifyReceived :: Address -> (UnixTime -> UnixTime) -> m ()
modifyReceived a :: Address
a f :: UnixTime -> UnixTime
f = do
    Balance
b <- Address -> m Balance
forall (m :: * -> *). StoreReadBase m => Address -> m Balance
getDefaultBalance Address
a
    Balance -> m ()
forall (m :: * -> *). StoreWrite m => Balance -> m ()
setBalance Balance
b { balanceTotalReceived :: UnixTime
balanceTotalReceived = UnixTime -> UnixTime
f (Balance -> UnixTime
balanceTotalReceived Balance
b) }

decreaseBalance :: MonadImport m => Bool -> Address -> Word64 -> m ()
decreaseBalance :: Bool -> Address -> UnixTime -> m ()
decreaseBalance conf :: Bool
conf = Bool -> Bool -> Address -> UnixTime -> m ()
forall (m :: * -> *).
MonadImport m =>
Bool -> Bool -> Address -> UnixTime -> m ()
modBalance Bool
conf Bool
False

increaseBalance :: MonadImport m => Bool -> Address -> Word64 -> m ()
increaseBalance :: Bool -> Address -> UnixTime -> m ()
increaseBalance conf :: Bool
conf = Bool -> Bool -> Address -> UnixTime -> m ()
forall (m :: * -> *).
MonadImport m =>
Bool -> Bool -> Address -> UnixTime -> m ()
modBalance Bool
conf Bool
True

modBalance :: MonadImport m
           => Bool -- ^ confirmed
           -> Bool -- ^ add
           -> Address
           -> Word64
           -> m ()
modBalance :: Bool -> Bool -> Address -> UnixTime -> m ()
modBalance conf :: Bool
conf add :: Bool
add a :: Address
a val :: UnixTime
val = do
    Balance
b <- Address -> m Balance
forall (m :: * -> *). StoreReadBase m => Address -> m Balance
getDefaultBalance Address
a
    Balance -> m ()
forall (m :: * -> *). StoreWrite m => Balance -> m ()
setBalance (Balance -> m ()) -> Balance -> m ()
forall a b. (a -> b) -> a -> b
$ (Balance -> Balance
g (Balance -> Balance) -> (Balance -> Balance) -> Balance -> Balance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Balance -> Balance
f) Balance
b
  where
    g :: Balance -> Balance
g b :: Balance
b = Balance
b { balanceUnspentCount :: UnixTime
balanceUnspentCount = UnixTime -> UnixTime -> UnixTime
m 1 (Balance -> UnixTime
balanceUnspentCount Balance
b) }
    f :: Balance -> Balance
f b :: Balance
b | Bool
conf = Balance
b { balanceAmount :: UnixTime
balanceAmount = UnixTime -> UnixTime -> UnixTime
m UnixTime
val (Balance -> UnixTime
balanceAmount Balance
b) }
        | Bool
otherwise = Balance
b { balanceZero :: UnixTime
balanceZero = UnixTime -> UnixTime -> UnixTime
m UnixTime
val (Balance -> UnixTime
balanceZero Balance
b) }
    m :: UnixTime -> UnixTime -> UnixTime
m | Bool
add = UnixTime -> UnixTime -> UnixTime
forall a. Num a => a -> a -> a
(+)
      | Bool
otherwise = UnixTime -> UnixTime -> UnixTime
forall a. Num a => a -> a -> a
subtract

modAddressCount :: MonadImport m => Bool -> Address -> m ()
modAddressCount :: Bool -> Address -> m ()
modAddressCount add :: Bool
add a :: Address
a = do
    Balance
b <- Address -> m Balance
forall (m :: * -> *). StoreReadBase m => Address -> m Balance
getDefaultBalance Address
a
    Balance -> m ()
forall (m :: * -> *). StoreWrite m => Balance -> m ()
setBalance Balance
b {balanceTxCount :: UnixTime
balanceTxCount = UnixTime -> UnixTime
f (Balance -> UnixTime
balanceTxCount Balance
b)}
  where
    f :: UnixTime -> UnixTime
f | Bool
add = (UnixTime -> UnixTime -> UnixTime
forall a. Num a => a -> a -> a
+ 1)
      | Bool
otherwise = UnixTime -> UnixTime -> UnixTime
forall a. Num a => a -> a -> a
subtract 1

txOutAddrs :: [TxOut] -> [Address]
txOutAddrs :: [TxOut] -> [Address]
txOutAddrs = [Address] -> [Address]
forall a. (Eq a, Hashable a) => [a] -> [a]
nub' ([Address] -> [Address])
-> ([TxOut] -> [Address]) -> [TxOut] -> [Address]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either String Address] -> [Address]
forall a b. [Either a b] -> [b]
rights ([Either String Address] -> [Address])
-> ([TxOut] -> [Either String Address]) -> [TxOut] -> [Address]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOut -> Either String Address)
-> [TxOut] -> [Either String Address]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> Either String Address
scriptToAddressBS (ByteString -> Either String Address)
-> (TxOut -> ByteString) -> TxOut -> Either String Address
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut -> ByteString
scriptOutput)

txInAddrs :: [Prev] -> [Address]
txInAddrs :: [Prev] -> [Address]
txInAddrs = [Address] -> [Address]
forall a. (Eq a, Hashable a) => [a] -> [a]
nub' ([Address] -> [Address])
-> ([Prev] -> [Address]) -> [Prev] -> [Address]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either String Address] -> [Address]
forall a b. [Either a b] -> [b]
rights ([Either String Address] -> [Address])
-> ([Prev] -> [Either String Address]) -> [Prev] -> [Address]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Prev -> Either String Address)
-> [Prev] -> [Either String Address]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> Either String Address
scriptToAddressBS (ByteString -> Either String Address)
-> (Prev -> ByteString) -> Prev -> Either String Address
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prev -> ByteString
prevScript)

txDataAddresses :: TxData -> [Address]
txDataAddresses :: TxData -> [Address]
txDataAddresses t :: TxData
t =
    [Address] -> [Address]
forall a. (Eq a, Hashable a) => [a] -> [a]
nub' ([Address] -> [Address]) -> [Address] -> [Address]
forall a b. (a -> b) -> a -> b
$ [Prev] -> [Address]
txInAddrs [Prev]
prevs [Address] -> [Address] -> [Address]
forall a. Semigroup a => a -> a -> a
<> [TxOut] -> [Address]
txOutAddrs [TxOut]
outs
  where
    prevs :: [Prev]
prevs = IntMap Prev -> [Prev]
forall a. IntMap a -> [a]
I.elems (TxData -> IntMap Prev
txDataPrevs TxData
t)
    outs :: [TxOut]
outs = Tx -> [TxOut]
txOut (TxData -> Tx
txData TxData
t)

isCoinbase :: Tx -> Bool
isCoinbase :: Tx -> Bool
isCoinbase = (TxIn -> Bool) -> [TxIn] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((OutPoint -> OutPoint -> Bool
forall a. Eq a => a -> a -> Bool
== OutPoint
nullOutPoint) (OutPoint -> Bool) -> (TxIn -> OutPoint) -> TxIn -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxIn -> OutPoint
prevOutput) ([TxIn] -> Bool) -> (Tx -> [TxIn]) -> Tx -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx -> [TxIn]
txIn

prevOuts :: Tx -> [OutPoint]
prevOuts :: Tx -> [OutPoint]
prevOuts tx :: Tx
tx = (OutPoint -> Bool) -> [OutPoint] -> [OutPoint]
forall a. (a -> Bool) -> [a] -> [a]
filter (OutPoint -> OutPoint -> Bool
forall a. Eq a => a -> a -> Bool
/= OutPoint
nullOutPoint) ((TxIn -> OutPoint) -> [TxIn] -> [OutPoint]
forall a b. (a -> b) -> [a] -> [b]
map TxIn -> OutPoint
prevOutput (Tx -> [TxIn]
txIn Tx
tx))

testPresent :: StoreReadBase m => Tx -> m Bool
testPresent :: Tx -> m Bool
testPresent tx :: Tx
tx = Maybe TxData -> Bool
forall a. Maybe a -> Bool
isJust (Maybe TxData -> Bool) -> m (Maybe TxData) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxHash -> m (Maybe TxData)
forall (m :: * -> *). StoreReadBase m => TxHash -> m (Maybe TxData)
getActiveTxData (Tx -> TxHash
txHash Tx
tx)

streamThings :: Monad m
             => (Limits -> m [a])
             -> (a -> TxHash)
             -> Limits
             -> ConduitT () a m ()
streamThings :: (Limits -> m [a]) -> (a -> TxHash) -> Limits -> ConduitT () a m ()
streamThings f :: Limits -> m [a]
f g :: a -> TxHash
g l :: Limits
l =
    m [a] -> ConduitT () a m [a]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Limits -> m [a]
f Limits
l{limit :: Word32
limit = 50}) ConduitT () a m [a]
-> ([a] -> ConduitT () a m ()) -> ConduitT () a m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [] -> () -> ConduitT () a m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ls :: [a]
ls -> do
        (a -> ConduitT () a m ()) -> [a] -> ConduitT () a m [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> ConduitT () a m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield [a]
ls
        a -> ConduitT () a m ()
forall i. a -> ConduitT i a m ()
go ([a] -> a
forall a. [a] -> a
last [a]
ls)
  where
    go :: a -> ConduitT i a m ()
go x :: a
x =
        m [a] -> ConduitT i a m [a]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Limits -> m [a]
f (Word32 -> Word32 -> Maybe Start -> Limits
Limits 50 0 (Start -> Maybe Start
forall a. a -> Maybe a
Just (TxHash -> Start
AtTx (a -> TxHash
g a
x))))) ConduitT i a m [a]
-> ([a] -> ConduitT i a m ()) -> ConduitT i a m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        [] -> () -> ConduitT i a m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        ls :: [a]
ls -> do
            case (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((TxHash -> TxHash -> Bool
forall a. Eq a => a -> a -> Bool
== a -> TxHash
g a
x) (TxHash -> Bool) -> (a -> TxHash) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TxHash
g) [a]
ls of
                [] -> () -> ConduitT i a m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                ls' :: [a]
ls' -> do
                    (a -> ConduitT i a m ()) -> [a] -> ConduitT i a m [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> ConduitT i a m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield [a]
ls'
                    a -> ConduitT i a m ()
go ([a] -> a
forall a. [a] -> a
last [a]
ls')

joinStreams :: Monad m
            => (a -> a -> Ordering)
            -> [ConduitT () a m ()]
            -> ConduitT () a m ()
joinStreams :: (a -> a -> Ordering) -> [ConduitT () a m ()] -> ConduitT () a m ()
joinStreams c :: a -> a -> Ordering
c xs :: [ConduitT () a m ()]
xs = do
    let ss :: [SealedConduitT () a m ()]
ss = (ConduitT () a m () -> SealedConduitT () a m ())
-> [ConduitT () a m ()] -> [SealedConduitT () a m ()]
forall a b. (a -> b) -> [a] -> [b]
map ConduitT () a m () -> SealedConduitT () a m ()
forall i o (m :: * -> *) r.
ConduitT i o m r -> SealedConduitT i o m r
sealConduitT [ConduitT () a m ()]
xs
    [(SealedConduitT () a m (), a)]
ys <- ((SealedConduitT () a m (), Maybe a)
 -> Maybe (SealedConduitT () a m (), a))
-> [(SealedConduitT () a m (), Maybe a)]
-> [(SealedConduitT () a m (), a)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (SealedConduitT () a m (), Maybe a)
-> Maybe (SealedConduitT () a m (), a)
forall (f :: * -> *) a b. Functor f => (a, f b) -> f (a, b)
j ([(SealedConduitT () a m (), Maybe a)]
 -> [(SealedConduitT () a m (), a)])
-> ConduitT () a m [(SealedConduitT () a m (), Maybe a)]
-> ConduitT () a m [(SealedConduitT () a m (), a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          m [(SealedConduitT () a m (), Maybe a)]
-> ConduitT () a m [(SealedConduitT () a m (), Maybe a)]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((SealedConduitT () a m () -> m (SealedConduitT () a m (), Maybe a))
-> [SealedConduitT () a m ()]
-> m [(SealedConduitT () a m (), Maybe a)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (SealedConduitT () a m ()
-> Sink a m (Maybe a) -> m (SealedConduitT () a m (), Maybe a)
forall (m :: * -> *) a b.
Monad m =>
SealedConduitT () a m ()
-> Sink a m b -> m (SealedConduitT () a m (), b)
$$++ Sink a m (Maybe a)
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await) [SealedConduitT () a m ()]
ss)
    Maybe a -> [(SealedConduitT () a m (), a)] -> ConduitT () a m ()
forall (m :: * -> *) i.
Monad m =>
Maybe a -> [(SealedConduitT () a m (), a)] -> ConduitT i a m ()
go Maybe a
forall a. Maybe a
Nothing [(SealedConduitT () a m (), a)]
ys
  where
    j :: (a, f b) -> f (a, b)
j (x :: a
x, y :: f b
y) = (,) a
x (b -> (a, b)) -> f b -> f (a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f b
y
    go :: Maybe a -> [(SealedConduitT () a m (), a)] -> ConduitT i a m ()
go m :: Maybe a
m ys :: [(SealedConduitT () a m (), a)]
ys =
        case ((SealedConduitT () a m (), a)
 -> (SealedConduitT () a m (), a) -> Ordering)
-> [(SealedConduitT () a m (), a)]
-> [(SealedConduitT () a m (), a)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (a -> a -> Ordering
c (a -> a -> Ordering)
-> ((SealedConduitT () a m (), a) -> a)
-> (SealedConduitT () a m (), a)
-> (SealedConduitT () a m (), a)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (SealedConduitT () a m (), a) -> a
forall a b. (a, b) -> b
snd) [(SealedConduitT () a m (), a)]
ys of
        [] -> () -> ConduitT i a m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (i :: SealedConduitT () a m ()
i,x :: a
x):ys' :: [(SealedConduitT () a m (), a)]
ys' -> do
            case Maybe a
m of
                Nothing -> a -> ConduitT i a m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield a
x
                Just x' :: a
x'
                  | a -> a -> Ordering
c a
x a
x' Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ -> () -> ConduitT i a m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  | Bool
otherwise -> a -> ConduitT i a m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield a
x
            (SealedConduitT () a m (), Maybe a)
-> Maybe (SealedConduitT () a m (), a)
forall (f :: * -> *) a b. Functor f => (a, f b) -> f (a, b)
j ((SealedConduitT () a m (), Maybe a)
 -> Maybe (SealedConduitT () a m (), a))
-> ConduitT i a m (SealedConduitT () a m (), Maybe a)
-> ConduitT i a m (Maybe (SealedConduitT () a m (), a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (SealedConduitT () a m (), Maybe a)
-> ConduitT i a m (SealedConduitT () a m (), Maybe a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (SealedConduitT () a m ()
i SealedConduitT () a m ()
-> Sink a m (Maybe a) -> m (SealedConduitT () a m (), Maybe a)
forall (m :: * -> *) a b.
Monad m =>
SealedConduitT () a m ()
-> Sink a m b -> m (SealedConduitT () a m (), b)
$$++ Sink a m (Maybe a)
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await) ConduitT i a m (Maybe (SealedConduitT () a m (), a))
-> (Maybe (SealedConduitT () a m (), a) -> ConduitT i a m ())
-> ConduitT i a m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Nothing -> Maybe a -> [(SealedConduitT () a m (), a)] -> ConduitT i a m ()
go (a -> Maybe a
forall a. a -> Maybe a
Just a
x) [(SealedConduitT () a m (), a)]
ys'
                Just y :: (SealedConduitT () a m (), a)
y -> Maybe a -> [(SealedConduitT () a m (), a)] -> ConduitT i a m ()
go (a -> Maybe a
forall a. a -> Maybe a
Just a
x) ((SealedConduitT () a m (), a)
y(SealedConduitT () a m (), a)
-> [(SealedConduitT () a m (), a)]
-> [(SealedConduitT () a m (), a)]
forall a. a -> [a] -> [a]
:[(SealedConduitT () a m (), a)]
ys')