{-# 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,
)
where
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.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import qualified Data.IntMap.Strict as I
import Data.List (nub)
import Data.Maybe
( catMaybes,
fromMaybe,
isJust,
isNothing,
)
import Data.Serialize (encode)
import Data.String.Conversions (cs)
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,
isCoinbaseTx,
txDataFee,
)
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
deriving (ImportException -> ImportException -> Bool
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
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
Ord, Show ImportException
Typeable 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
Exception)
instance Show ImportException where
show :: ImportException -> String
show ImportException
PrevBlockNotBest = String
"Previous block not best"
show ImportException
Orphan = String
"Orphan"
show ImportException
UnexpectedCoinbase = String
"Unexpected coinbase"
show ImportException
BestBlockNotFound = String
"Best block not found"
show ImportException
BlockNotBest = String
"Block not best"
show ImportException
TxNotFound = String
"Transaction not found"
show ImportException
DoubleSpend = String
"Double spend"
show ImportException
TxConfirmed = String
"Transaction confirmed"
show ImportException
InsufficientFunds = String
"Insufficient funds"
show ImportException
DuplicatePrevOutput = String
"Duplicate previous output"
show ImportException
TxSpent = String
"Transaction is spent"
initBest :: MonadImport m => m ()
initBest :: forall (m :: * -> *). MonadImport m => m ()
initBest = do
$(logDebugS) Text
"BlockStore" Text
"Initializing best block"
Network
net <- forall (m :: * -> *). StoreReadBase m => m Network
getNetwork
Maybe BlockHash
m <- forall (m :: * -> *). StoreReadBase m => m (Maybe BlockHash)
getBestBlock
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe BlockHash
m) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ do
$(logDebugS) Text
"BlockStore" Text
"Importing Genesis block"
forall (m :: * -> *).
MonadImport m =>
Block -> BlockNode -> m (BlockData, [TxData])
importBlock (Network -> Block
genesisBlock Network
net) (Network -> BlockNode
genesisNode Network
net)
newMempoolTx :: MonadImport m => Tx -> UnixTime -> m Bool
newMempoolTx :: forall (m :: * -> *). MonadImport m => Tx -> UnixTime -> m Bool
newMempoolTx Tx
tx UnixTime
w =
forall (m :: * -> *). StoreReadBase m => TxHash -> m (Maybe TxData)
getActiveTxData (Tx -> TxHash
txHash Tx
tx) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just TxData
_ ->
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Maybe TxData
Nothing -> do
forall (m :: * -> *). MonadImport m => Bool -> Bool -> Tx -> m ()
freeOutputs Bool
True Bool
True Tx
tx
Bool
rbf <- forall (m :: * -> *). StoreReadBase m => BlockRef -> Tx -> m Bool
isRBF (UnixTime -> BlockRef
MemRef UnixTime
w) Tx
tx
forall (m :: * -> *). MonadImport m => Tx -> m ()
checkNewTx Tx
tx
forall (m :: * -> *).
MonadImport m =>
BlockRef -> UnixTime -> Bool -> Tx -> m TxData
importTx (UnixTime -> BlockRef
MemRef UnixTime
w) UnixTime
w Bool
rbf Tx
tx
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
bestBlockData :: MonadImport m => m BlockData
bestBlockData :: forall (m :: * -> *). MonadImport m => m BlockData
bestBlockData = do
BlockHash
h <-
forall (m :: * -> *). StoreReadBase m => m (Maybe BlockHash)
getBestBlock forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe BlockHash
Nothing -> do
$(logErrorS) Text
"BlockStore" Text
"Best block unknown"
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
BestBlockNotFound
Just BlockHash
h -> forall (m :: * -> *) a. Monad m => a -> m a
return BlockHash
h
forall (m :: * -> *).
StoreReadBase m =>
BlockHash -> m (Maybe BlockData)
getBlock BlockHash
h forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe BlockData
Nothing -> do
$(logErrorS) Text
"BlockStore" Text
"Best block not found"
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
BestBlockNotFound
Just BlockData
b -> forall (m :: * -> *) a. Monad m => a -> m a
return BlockData
b
revertBlock :: MonadImport m => BlockHash -> m ()
revertBlock :: forall (m :: * -> *). MonadImport m => BlockHash -> m ()
revertBlock BlockHash
bh = do
BlockData
bd <-
forall (m :: * -> *). MonadImport m => m BlockData
bestBlockData forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \BlockData
b ->
if BlockHeader -> BlockHash
headerHash (BlockData -> BlockHeader
blockDataHeader BlockData
b) forall a. Eq a => a -> a -> Bool
== BlockHash
bh
then forall (m :: * -> *) a. Monad m => a -> m a
return BlockData
b
else do
$(logErrorS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Cannot revert non-head block: " forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
bh
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
BlockNotBest
$(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Obtained block data for " forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
bh
[TxData]
tds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). MonadImport m => TxHash -> m TxData
getImportTxData (BlockData -> [TxHash]
blockDataTxs BlockData
bd)
$(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Obtained import tx data for block " forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
bh
forall (m :: * -> *). StoreWrite m => BlockHash -> m ()
setBest (BlockHeader -> BlockHash
prevBlock (BlockData -> BlockHeader
blockDataHeader BlockData
bd))
$(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Set parent as best block "
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex (BlockHeader -> BlockHash
prevBlock (BlockData -> BlockHeader
blockDataHeader BlockData
bd))
forall (m :: * -> *). StoreWrite m => BlockData -> m ()
insertBlock BlockData
bd {blockDataMainChain :: Bool
blockDataMainChain = Bool
False}
$(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Updated as not in main chain: " forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex BlockHash
bh
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. [a] -> [a]
tail [TxData]
tds) forall (m :: * -> *). MonadImport m => TxData -> m TxData
unConfirmTx
$(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Unconfirmed " forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxData]
tds)) forall a. Semigroup a => a -> a -> a
<> Text
" transactions"
forall (m :: * -> *). MonadImport m => TxHash -> m ()
deleteConfirmedTx (Tx -> TxHash
txHash (TxData -> Tx
txData (forall a. [a] -> a
head [TxData]
tds)))
$(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Deleted coinbase: " forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash (TxData -> Tx
txData (forall a. [a] -> a
head [TxData]
tds)))
checkNewBlock :: MonadImport m => Block -> BlockNode -> m ()
checkNewBlock :: forall (m :: * -> *). MonadImport m => Block -> BlockNode -> m ()
checkNewBlock Block
b BlockNode
n =
forall (m :: * -> *). StoreReadBase m => m (Maybe BlockHash)
getBestBlock forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe BlockHash
Nothing
| BlockNode -> Bool
isGenesis BlockNode
n -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise -> do
$(logErrorS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Cannot import non-genesis block: "
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex (BlockHeader -> BlockHash
headerHash (Block -> BlockHeader
blockHeader Block
b))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
BestBlockNotFound
Just BlockHash
h
| BlockHeader -> BlockHash
prevBlock (Block -> BlockHeader
blockHeader Block
b) forall a. Eq a => a -> a -> Bool
== BlockHash
h -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise -> do
$(logErrorS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Block does not build on head: "
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex (BlockHeader -> BlockHash
headerHash (Block -> BlockHeader
blockHeader Block
b))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
PrevBlockNotBest
importOrConfirm :: MonadImport m => BlockNode -> [Tx] -> m [TxData]
importOrConfirm :: forall (m :: * -> *).
MonadImport m =>
BlockNode -> [Tx] -> m [TxData]
importOrConfirm BlockNode
bn [Tx]
txns = do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). MonadImport m => Bool -> Bool -> Tx -> m ()
freeOutputs Bool
True Bool
False forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (forall a. [a] -> [a]
reverse [(Word32, Tx)]
txs)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall {m :: * -> *}.
(StoreReadBase m, MonadError ImportException m, MonadLoggerIO m,
StoreWrite m) =>
Word32 -> Tx -> m TxData
action) [(Word32, Tx)]
txs
where
txs :: [(Word32, Tx)]
txs = [Tx] -> [(Word32, Tx)]
sortTxs [Tx]
txns
br :: Word32 -> BlockRef
br Word32
i = BlockRef {blockRefHeight :: Word32
blockRefHeight = BlockNode -> Word32
nodeHeight BlockNode
bn, blockRefPos :: Word32
blockRefPos = Word32
i}
bn_time :: UnixTime
bn_time = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHeader -> Word32
blockTimestamp forall a b. (a -> b) -> a -> b
$ BlockNode -> BlockHeader
nodeHeader BlockNode
bn
action :: Word32 -> Tx -> m TxData
action Word32
i Tx
tx =
forall (m :: * -> *). StoreReadBase m => Tx -> m Bool
testPresent Tx
tx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False -> forall {m :: * -> *}.
(MonadError ImportException m, MonadLoggerIO m, StoreReadBase m,
StoreWrite m) =>
Word32 -> Tx -> m TxData
import_it Word32
i Tx
tx
Bool
True -> forall {m :: * -> *}.
(StoreReadBase m, MonadError ImportException m, MonadLoggerIO m,
StoreWrite m) =>
Word32 -> Tx -> m TxData
confirm_it Word32
i Tx
tx
confirm_it :: Word32 -> Tx -> m TxData
confirm_it Word32
i Tx
tx =
forall (m :: * -> *). StoreReadBase m => TxHash -> m (Maybe TxData)
getActiveTxData (Tx -> TxHash
txHash Tx
tx) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just TxData
t -> do
$(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Confirming tx: "
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
forall (m :: * -> *).
MonadImport m =>
TxData -> BlockRef -> m TxData
confirmTx TxData
t (Word32 -> BlockRef
br Word32
i)
Maybe TxData
Nothing -> do
$(logErrorS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Cannot find tx to confirm: "
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
TxNotFound
import_it :: Word32 -> Tx -> m TxData
import_it Word32
i Tx
tx = do
$(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Importing tx: " forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
forall (m :: * -> *).
MonadImport m =>
BlockRef -> UnixTime -> Bool -> Tx -> m TxData
importTx (Word32 -> BlockRef
br Word32
i) UnixTime
bn_time Bool
False Tx
tx
importBlock :: MonadImport m => Block -> BlockNode -> m (BlockData, [TxData])
importBlock :: forall (m :: * -> *).
MonadImport m =>
Block -> BlockNode -> m (BlockData, [TxData])
importBlock Block
b BlockNode
n = do
$(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Checking new block: "
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex (BlockHeader -> BlockHash
headerHash (BlockNode -> BlockHeader
nodeHeader BlockNode
n))
forall (m :: * -> *). MonadImport m => Block -> BlockNode -> m ()
checkNewBlock Block
b BlockNode
n
$(logDebugS) Text
"BlockStore" Text
"Passed check"
Network
net <- forall (m :: * -> *). StoreReadBase m => m Network
getNetwork
let subsidy :: UnixTime
subsidy = Network -> Word32 -> UnixTime
computeSubsidy Network
net (BlockNode -> Word32
nodeHeight BlockNode
n)
[BlockHash]
bs <- forall (m :: * -> *). StoreReadBase m => Word32 -> m [BlockHash]
getBlocksAtHeight (BlockNode -> Word32
nodeHeight BlockNode
n)
$(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Inserting block entries for: "
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex (BlockHeader -> BlockHash
headerHash (BlockNode -> BlockHeader
nodeHeader BlockNode
n))
forall (m :: * -> *). StoreWrite m => [BlockHash] -> Word32 -> m ()
setBlocksAtHeight
(forall a. Eq a => [a] -> [a]
nub (BlockHeader -> BlockHash
headerHash (BlockNode -> BlockHeader
nodeHeader BlockNode
n) forall a. a -> [a] -> [a]
: [BlockHash]
bs))
(BlockNode -> Word32
nodeHeight BlockNode
n)
forall (m :: * -> *). StoreWrite m => BlockHash -> m ()
setBest (BlockHeader -> BlockHash
headerHash (BlockNode -> BlockHeader
nodeHeader BlockNode
n))
[TxData]
tds <- forall (m :: * -> *).
MonadImport m =>
BlockNode -> [Tx] -> m [TxData]
importOrConfirm BlockNode
n (Block -> [Tx]
blockTxns Block
b)
let bd :: BlockData
bd =
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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length (forall a. Serialize a => a -> ByteString
encode Block
b)),
blockDataTxs :: [TxHash]
blockDataTxs = 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 Word32
0,
blockDataSubsidy :: UnixTime
blockDataSubsidy = UnixTime
subsidy,
blockDataFees :: UnixTime
blockDataFees = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map TxData -> UnixTime
txDataFee [TxData]
tds,
blockDataOutputs :: UnixTime
blockDataOutputs = UnixTime
ts_out_val
}
forall (m :: * -> *). StoreWrite m => BlockData -> m ()
insertBlock BlockData
bd
$(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Finished importing block: "
forall a. Semigroup a => a -> a -> a
<> BlockHash -> Text
blockHashToHex (BlockHeader -> BlockHash
headerHash (BlockNode -> BlockHeader
nodeHeader BlockNode
n))
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockData
bd, [TxData]
tds)
where
cb_out_val :: UnixTime
cb_out_val =
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map TxOut -> UnixTime
outValue forall a b. (a -> b) -> a -> b
$ Tx -> [TxOut]
txOut forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ Block -> [Tx]
blockTxns Block
b
ts_out_val :: UnixTime
ts_out_val =
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map TxOut -> UnixTime
outValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx -> [TxOut]
txOut) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ Block -> [Tx]
blockTxns Block
b
w :: Word32
w =
let f :: Tx -> Tx
f Tx
t = Tx
t {txWitness :: WitnessData
txWitness = []}
b' :: Block
b' = Block
b {blockTxns :: [Tx]
blockTxns = forall a b. (a -> b) -> [a] -> [b]
map Tx -> Tx
f (Block -> [Tx]
blockTxns Block
b)}
x :: Int
x = ByteString -> Int
B.length (forall a. Serialize a => a -> ByteString
encode Block
b)
s :: Int
s = ByteString -> Int
B.length (forall a. Serialize a => a -> ByteString
encode Block
b')
in forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
s forall a. Num a => a -> a -> a
* Int
3 forall a. Num a => a -> a -> a
+ Int
x
checkNewTx :: MonadImport m => Tx -> m ()
checkNewTx :: forall (m :: * -> *). MonadImport m => Tx -> m ()
checkNewTx Tx
tx = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
unique_inputs forall a. Ord a => a -> a -> Bool
< forall (t :: * -> *) a. Foldable t => t a -> Int
length (Tx -> [TxIn]
txIn Tx
tx)) forall a b. (a -> b) -> a -> b
$ do
$(logErrorS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Transaction spends same output twice: "
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
DuplicatePrevOutput
[Maybe Unspent]
us <- forall (m :: * -> *). StoreReadBase m => Tx -> m [Maybe Unspent]
getUnspentOutputs Tx
tx
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a. Maybe a -> Bool
isNothing [Maybe Unspent]
us) forall a b. (a -> b) -> a -> b
$ do
$(logErrorS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Orphan: " forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
Orphan
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Tx -> Bool
isCoinbaseTx Tx
tx) forall a b. (a -> b) -> a -> b
$ do
$(logErrorS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Coinbase cannot be imported into mempool: "
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
UnexpectedCoinbase
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length (Tx -> [OutPoint]
prevOuts Tx
tx) forall a. Ord a => a -> a -> Bool
> forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe Unspent]
us) forall a b. (a -> b) -> a -> b
$ do
$(logErrorS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Orphan: " forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
Orphan
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UnixTime
outputs forall a. Ord a => a -> a -> Bool
> [Maybe Unspent] -> UnixTime
unspents [Maybe Unspent]
us) forall a b. (a -> b) -> a -> b
$ do
$(logErrorS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Insufficient funds for tx: " forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
InsufficientFunds
where
unspents :: [Maybe Unspent] -> UnixTime
unspents = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Unspent -> UnixTime
unspentAmount forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes
outputs :: UnixTime
outputs = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map TxOut -> UnixTime
outValue (Tx -> [TxOut]
txOut Tx
tx))
unique_inputs :: Int
unique_inputs = forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (Eq a, Hashable a) => [a] -> [a]
nub' (forall a b. (a -> b) -> [a] -> [b]
map TxIn -> OutPoint
prevOutput (Tx -> [TxIn]
txIn Tx
tx)))
getUnspentOutputs :: StoreReadBase m => Tx -> m [Maybe Unspent]
getUnspentOutputs :: forall (m :: * -> *). StoreReadBase m => Tx -> m [Maybe Unspent]
getUnspentOutputs Tx
tx = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM 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 Bool
rbf BlockRef
br UnixTime
tt Tx
tx [Unspent]
us =
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,
txDataSpenders :: IntMap Spender
txDataSpenders = forall a. IntMap a
I.empty
}
where
mkprv :: Unspent -> Prev
mkprv Unspent
u = ByteString -> UnixTime -> Prev
Prev (Unspent -> ByteString
unspentScript Unspent
u) (Unspent -> UnixTime
unspentAmount Unspent
u)
ps :: IntMap Prev
ps = forall a. [(Int, a)] -> IntMap a
I.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Unspent -> Prev
mkprv [Unspent]
us
importTx ::
MonadImport m =>
BlockRef ->
Word64 ->
Bool ->
Tx ->
m TxData
importTx :: forall (m :: * -> *).
MonadImport m =>
BlockRef -> UnixTime -> Bool -> Tx -> m TxData
importTx BlockRef
br UnixTime
tt Bool
rbf Tx
tx = do
[Maybe Unspent]
mus <- forall (m :: * -> *). StoreReadBase m => Tx -> m [Maybe Unspent]
getUnspentOutputs Tx
tx
[Unspent]
us <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Maybe Unspent]
mus forall a b. (a -> b) -> a -> b
$ \case
Maybe Unspent
Nothing -> do
$(logErrorS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Attempted to import a tx missing UTXO: "
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex (Tx -> TxHash
txHash Tx
tx)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
Orphan
Just Unspent
u -> 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
forall (m :: * -> *). MonadImport m => TxData -> m ()
commitAddTx TxData
td
forall (m :: * -> *) a. Monad m => a -> m a
return TxData
td
unConfirmTx :: MonadImport m => TxData -> m TxData
unConfirmTx :: forall (m :: * -> *). MonadImport m => TxData -> m TxData
unConfirmTx TxData
t = forall (m :: * -> *).
MonadImport m =>
TxData -> Maybe BlockRef -> m TxData
confTx TxData
t forall a. Maybe a
Nothing
confirmTx :: MonadImport m => TxData -> BlockRef -> m TxData
confirmTx :: forall (m :: * -> *).
MonadImport m =>
TxData -> BlockRef -> m TxData
confirmTx TxData
t BlockRef
br = forall (m :: * -> *).
MonadImport m =>
TxData -> Maybe BlockRef -> m TxData
confTx TxData
t (forall a. a -> Maybe a
Just BlockRef
br)
replaceAddressTx :: MonadImport m => TxData -> BlockRef -> m ()
replaceAddressTx :: forall (m :: * -> *). MonadImport m => TxData -> BlockRef -> m ()
replaceAddressTx TxData
t BlockRef
new = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (TxData -> [Address]
txDataAddresses TxData
t) forall a b. (a -> b) -> a -> b
$ \Address
a -> do
forall (m :: * -> *). StoreWrite m => Address -> TxRef -> m ()
deleteAddrTx
Address
a
TxRef
{ txRefBlock :: BlockRef
txRefBlock = TxData -> BlockRef
txDataBlock TxData
t,
txRefHash :: TxHash
txRefHash = Tx -> TxHash
txHash (TxData -> Tx
txData TxData
t)
}
forall (m :: * -> *). StoreWrite m => Address -> TxRef -> m ()
insertAddrTx
Address
a
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 :: forall (m :: * -> *).
MonadImport m =>
OutPoint -> TxOut -> BlockRef -> BlockRef -> m ()
adjustAddressOutput OutPoint
op TxOut
o BlockRef
old BlockRef
new = do
let pk :: ByteString
pk = TxOut -> ByteString
scriptOutput TxOut
o
forall (m :: * -> *).
StoreReadBase m =>
OutPoint -> m (Maybe Unspent)
getUnspent OutPoint
op forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Unspent
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Unspent
u -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Unspent -> BlockRef
unspentBlock Unspent
u forall a. Eq a => a -> a -> Bool
== BlockRef
old) forall a b. (a -> b) -> a -> b
$
forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Existing unspent block bad for output: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show OutPoint
op
forall {m :: * -> *}.
(StoreWrite m, MonadError ImportException m, MonadLoggerIO m,
StoreReadBase m) =>
ByteString -> m ()
replace_unspent ByteString
pk
where
replace_unspent :: ByteString -> m ()
replace_unspent ByteString
pk = do
let ma :: Maybe Address
ma = forall a b. Either a b -> Maybe b
eitherToMaybe (ByteString -> Either String Address
scriptToAddressBS ByteString
pk)
forall (m :: * -> *). StoreWrite m => OutPoint -> m ()
deleteUnspent OutPoint
op
forall (m :: * -> *). StoreWrite m => Unspent -> m ()
insertUnspent
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
}
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Address
ma forall a b. (a -> b) -> a -> b
$ 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 ByteString
pk Address
a = do
forall (m :: * -> *). StoreWrite m => Address -> Unspent -> m ()
deleteAddrUnspent
Address
a
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 = forall a. a -> Maybe a
Just Address
a
}
forall (m :: * -> *). StoreWrite m => Address -> Unspent -> m ()
insertAddrUnspent
Address
a
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 = forall a. a -> Maybe a
Just Address
a
}
forall (m :: * -> *).
MonadImport m =>
Bool -> Address -> UnixTime -> m ()
decreaseBalance (BlockRef -> Bool
confirmed BlockRef
old) Address
a (TxOut -> UnixTime
outValue TxOut
o)
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 TxData
confTx :: forall (m :: * -> *).
MonadImport m =>
TxData -> Maybe BlockRef -> m TxData
confTx TxData
t Maybe BlockRef
mbr = do
forall (m :: * -> *). MonadImport m => TxData -> BlockRef -> m ()
replaceAddressTx TxData
t BlockRef
new
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Word32
0 ..] (Tx -> [TxOut]
txOut (TxData -> Tx
txData TxData
t))) forall a b. (a -> b) -> a -> b
$ \(Word32
n, TxOut
o) -> do
let op :: OutPoint
op = TxHash -> Word32 -> OutPoint
OutPoint (Tx -> TxHash
txHash (TxData -> Tx
txData TxData
t)) Word32
n
forall (m :: * -> *).
MonadImport m =>
OutPoint -> TxOut -> BlockRef -> BlockRef -> m ()
adjustAddressOutput OutPoint
op TxOut
o BlockRef
old BlockRef
new
Bool
rbf <- 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}
forall (m :: * -> *). StoreWrite m => TxData -> m ()
insertTx TxData
td
forall (m :: * -> *). MonadImport m => TxData -> m ()
updateMempool TxData
td
forall (m :: * -> *) a. Monad m => a -> m a
return TxData
td
where
new :: BlockRef
new = 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 ->
Bool ->
Tx ->
m ()
freeOutputs :: forall (m :: * -> *). MonadImport m => Bool -> Bool -> Tx -> m ()
freeOutputs Bool
memonly Bool
rbfcheck Tx
tx = do
let prevs :: [OutPoint]
prevs = Tx -> [OutPoint]
prevOuts Tx
tx
[Maybe Unspent]
unspents <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
StoreReadBase m =>
OutPoint -> m (Maybe Unspent)
getUnspent [OutPoint]
prevs
let spents :: [OutPoint]
spents = [OutPoint
p | (OutPoint
p, Maybe Unspent
Nothing) <- forall a b. [a] -> [b] -> [(a, b)]
zip [OutPoint]
prevs [Maybe Unspent]
unspents]
[Spender]
spndrs <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
StoreReadBase m =>
OutPoint -> m (Maybe Spender)
getSpender [OutPoint]
spents
let txids :: HashSet TxHash
txids = forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Tx -> TxHash
txHash Tx
tx) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Spender -> TxHash
spenderHash [Spender]
spndrs
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *).
MonadImport m =>
Bool -> Bool -> TxHash -> m ()
deleteTx Bool
memonly Bool
rbfcheck) forall a b. (a -> b) -> a -> b
$ forall a. HashSet a -> [a]
HashSet.toList HashSet TxHash
txids
deleteConfirmedTx :: MonadImport m => TxHash -> m ()
deleteConfirmedTx :: forall (m :: * -> *). MonadImport m => TxHash -> m ()
deleteConfirmedTx = forall (m :: * -> *).
MonadImport m =>
Bool -> Bool -> TxHash -> m ()
deleteTx Bool
False Bool
False
deleteUnconfirmedTx :: MonadImport m => Bool -> TxHash -> m ()
deleteUnconfirmedTx :: forall (m :: * -> *). MonadImport m => Bool -> TxHash -> m ()
deleteUnconfirmedTx Bool
rbfcheck TxHash
th =
forall (m :: * -> *). StoreReadBase m => TxHash -> m (Maybe TxData)
getActiveTxData TxHash
th forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just TxData
_ -> forall (m :: * -> *).
MonadImport m =>
Bool -> Bool -> TxHash -> m ()
deleteTx Bool
True Bool
rbfcheck TxHash
th
Maybe TxData
Nothing ->
$(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Not found or already deleted: " forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
th
deleteTx ::
MonadImport m =>
Bool ->
Bool ->
TxHash ->
m ()
deleteTx :: forall (m :: * -> *).
MonadImport m =>
Bool -> Bool -> TxHash -> m ()
deleteTx Bool
memonly Bool
rbfcheck TxHash
th = do
[Tx]
chain <- forall (m :: * -> *).
(MonadImport m, MonadLoggerIO m) =>
Bool -> Bool -> TxHash -> m [Tx]
getChain Bool
memonly Bool
rbfcheck TxHash
th
$(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Deleting " forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertibleStrings a b => a -> b
cs (forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx]
chain))
forall a. Semigroup a => a -> a -> a
<> Text
" txs from chain leading to "
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
th
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Tx
t -> let h :: TxHash
h = Tx -> TxHash
txHash Tx
t in forall (m :: * -> *). MonadImport m => TxHash -> m ()
deleteSingleTx TxHash
h forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return TxHash
h) [Tx]
chain
getChain ::
(MonadImport m, MonadLoggerIO m) =>
Bool ->
Bool ->
TxHash ->
m [Tx]
getChain :: forall (m :: * -> *).
(MonadImport m, MonadLoggerIO m) =>
Bool -> Bool -> TxHash -> m [Tx]
getChain Bool
memonly Bool
rbfcheck TxHash
th' = do
$(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Getting chain for tx " forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
th'
[Tx] -> [Tx]
sort_clean forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {m :: * -> *}.
(StoreReadBase m, MonadLogger m, MonadError ImportException m) =>
HashSet Tx -> HashSet TxHash -> m [Tx]
go forall a. HashSet a
HashSet.empty (forall a. Hashable a => a -> HashSet a
HashSet.singleton TxHash
th')
where
sort_clean :: [Tx] -> [Tx]
sort_clean = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tx] -> [(Word32, Tx)]
sortTxs
get_tx :: TxHash -> m (Maybe TxData)
get_tx TxHash
th =
forall (m :: * -> *). StoreReadBase m => TxHash -> m (Maybe TxData)
getActiveTxData TxHash
th forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe TxData
Nothing -> do
$(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Transaction not found: " forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
th
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just TxData
td
| Bool
memonly Bool -> Bool -> Bool
&& BlockRef -> Bool
confirmed (TxData -> BlockRef
txDataBlock TxData
td) -> do
$(logErrorS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Transaction already confirmed: "
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
th
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
TxConfirmed
| Bool
rbfcheck ->
forall (m :: * -> *). StoreReadBase m => BlockRef -> Tx -> m Bool
isRBF (TxData -> BlockRef
txDataBlock TxData
td) (TxData -> Tx
txData TxData
td) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just TxData
td
Bool
False -> do
$(logErrorS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Double-spending transaction: "
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
th
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
DoubleSpend
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just TxData
td
go :: HashSet Tx -> HashSet TxHash -> m [Tx]
go HashSet Tx
txs HashSet TxHash
pdg = do
[TxData]
tds <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *}.
(StoreReadBase m, MonadLogger m, MonadError ImportException m) =>
TxHash -> m (Maybe TxData)
get_tx (forall a. HashSet a -> [a]
HashSet.toList HashSet TxHash
pdg)
let txsn :: HashSet Tx
txsn = forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxData -> Tx
txData [TxData]
tds
pdgn :: HashSet TxHash
pdgn =
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a -> b) -> [a] -> [b]
map Spender -> TxHash
spenderHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IntMap a -> [a]
I.elems)
forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxData -> IntMap Spender
txDataSpenders [TxData]
tds
txs' :: HashSet Tx
txs' = HashSet Tx
txsn forall a. Semigroup a => a -> a -> a
<> HashSet Tx
txs
pdg' :: HashSet TxHash
pdg' = HashSet TxHash
pdgn forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HashSet.difference` forall b a.
(Hashable b, Eq b) =>
(a -> b) -> HashSet a -> HashSet b
HashSet.map Tx -> TxHash
txHash HashSet Tx
txs'
if forall a. HashSet a -> Bool
HashSet.null HashSet TxHash
pdg'
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. HashSet a -> [a]
HashSet.toList HashSet Tx
txs'
else HashSet Tx -> HashSet TxHash -> m [Tx]
go HashSet Tx
txs' HashSet TxHash
pdg'
deleteSingleTx :: MonadImport m => TxHash -> m ()
deleteSingleTx :: forall (m :: * -> *). MonadImport m => TxHash -> m ()
deleteSingleTx TxHash
th =
forall (m :: * -> *). StoreReadBase m => TxHash -> m (Maybe TxData)
getActiveTxData TxHash
th forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe TxData
Nothing -> do
$(logErrorS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Already deleted: " forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
th
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
TxNotFound
Just TxData
td ->
if forall a. IntMap a -> Bool
I.null (TxData -> IntMap Spender
txDataSpenders TxData
td)
then do
$(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Deleting tx: " forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
th
forall (m :: * -> *). MonadImport m => TxData -> m ()
commitDelTx TxData
td
else do
$(logErrorS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$
Text
"Tried to delete spent tx: "
forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
th
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
TxSpent
commitDelTx :: MonadImport m => TxData -> m ()
commitDelTx :: forall (m :: * -> *). MonadImport m => TxData -> m ()
commitDelTx = forall (m :: * -> *). MonadImport m => Bool -> TxData -> m ()
commitModTx Bool
False
commitAddTx :: MonadImport m => TxData -> m ()
commitAddTx :: forall (m :: * -> *). MonadImport m => TxData -> m ()
commitAddTx = forall (m :: * -> *). MonadImport m => Bool -> TxData -> m ()
commitModTx Bool
True
commitModTx :: MonadImport m => Bool -> TxData -> m ()
commitModTx :: forall (m :: * -> *). MonadImport m => Bool -> TxData -> m ()
commitModTx Bool
add TxData
tx_data = do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ 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
forall (m :: * -> *). StoreWrite m => TxData -> m ()
insertTx TxData
td
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 Address
a
| Bool
add = do
forall (m :: * -> *). StoreWrite m => Address -> TxRef -> m ()
insertAddrTx Address
a TxRef
tx_ref
forall (m :: * -> *). MonadImport m => Bool -> Address -> m ()
modAddressCount Bool
add Address
a
| Bool
otherwise = do
forall (m :: * -> *). StoreWrite m => Address -> TxRef -> m ()
deleteAddrTx Address
a TxRef
tx_ref
forall (m :: * -> *). MonadImport m => Bool -> Address -> m ()
modAddressCount Bool
add Address
a
mod_unspent :: m ()
mod_unspent
| Bool
add = forall (m :: * -> *). MonadImport m => Tx -> m ()
spendOutputs Tx
tx
| Bool
otherwise = forall (m :: * -> *). MonadImport m => Tx -> m ()
unspendOutputs Tx
tx
mod_outputs :: m ()
mod_outputs
| Bool
add = forall (m :: * -> *). MonadImport m => BlockRef -> Tx -> m ()
addOutputs BlockRef
br Tx
tx
| Bool
otherwise = forall (m :: * -> *). MonadImport m => BlockRef -> Tx -> m ()
delOutputs BlockRef
br Tx
tx
updateMempool :: MonadImport m => TxData -> m ()
updateMempool :: forall (m :: * -> *). MonadImport m => TxData -> m ()
updateMempool td :: TxData
td@TxData {txDataDeleted :: TxData -> Bool
txDataDeleted = Bool
True} =
forall (m :: * -> *). StoreWrite m => TxHash -> m ()
deleteFromMempool (Tx -> TxHash
txHash (TxData -> Tx
txData TxData
td))
updateMempool td :: TxData
td@TxData {txDataBlock :: TxData -> BlockRef
txDataBlock = MemRef UnixTime
t} =
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 {}} =
forall (m :: * -> *). StoreWrite m => TxHash -> m ()
deleteFromMempool (Tx -> TxHash
txHash (TxData -> Tx
txData TxData
td))
spendOutputs :: MonadImport m => Tx -> m ()
spendOutputs :: forall (m :: * -> *). MonadImport m => Tx -> m ()
spendOutputs Tx
tx =
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (forall (m :: * -> *).
MonadImport m =>
TxHash -> Word32 -> OutPoint -> m ()
spendOutput (Tx -> TxHash
txHash Tx
tx)) [Word32
0 ..] (Tx -> [OutPoint]
prevOuts Tx
tx)
addOutputs :: MonadImport m => BlockRef -> Tx -> m ()
addOutputs :: forall (m :: * -> *). MonadImport m => BlockRef -> Tx -> m ()
addOutputs BlockRef
br Tx
tx =
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (forall (m :: * -> *).
MonadImport m =>
BlockRef -> OutPoint -> TxOut -> m ()
addOutput BlockRef
br forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxHash -> Word32 -> OutPoint
OutPoint (Tx -> TxHash
txHash Tx
tx)) [Word32
0 ..] (Tx -> [TxOut]
txOut Tx
tx)
isRBF ::
StoreReadBase m =>
BlockRef ->
Tx ->
m Bool
isRBF :: forall (m :: * -> *). StoreReadBase m => BlockRef -> Tx -> m Bool
isRBF BlockRef
br Tx
tx
| BlockRef -> Bool
confirmed BlockRef
br = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
| Bool
otherwise =
forall (m :: * -> *). StoreReadBase m => m Network
getNetwork forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Network
net ->
if Network -> Bool
getReplaceByFee Network
net
then m Bool
go
else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
where
go :: m Bool
go
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((forall a. Ord a => a -> a -> Bool
< Word32
0xffffffff forall a. Num a => a -> a -> a
- Word32
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxIn -> Word32
txInSequence) (Tx -> [TxIn]
txIn Tx
tx) = 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 = forall a. (Eq a, Hashable a) => [a] -> [a]
nub' forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (OutPoint -> TxHash
outPointHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxIn -> OutPoint
prevOutput) (Tx -> [TxIn]
txIn Tx
tx)
ck :: [TxHash] -> m Bool
ck [] = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
ck (TxHash
h : [TxHash]
hs') =
forall (m :: * -> *). StoreReadBase m => TxHash -> m (Maybe TxData)
getActiveTxData TxHash
h forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe TxData
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Just TxData
t
| BlockRef -> Bool
confirmed (TxData -> BlockRef
txDataBlock TxData
t) -> [TxHash] -> m Bool
ck [TxHash]
hs'
| TxData -> Bool
txDataRBF TxData
t -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
| Bool
otherwise -> [TxHash] -> m Bool
ck [TxHash]
hs'
in forall {m :: * -> *}. StoreReadBase m => [TxHash] -> m Bool
ck [TxHash]
hs
addOutput :: MonadImport m => BlockRef -> OutPoint -> TxOut -> m ()
addOutput :: forall (m :: * -> *).
MonadImport m =>
BlockRef -> OutPoint -> TxOut -> m ()
addOutput = forall (m :: * -> *).
MonadImport m =>
Bool -> BlockRef -> OutPoint -> TxOut -> m ()
modOutput Bool
True
delOutput :: MonadImport m => BlockRef -> OutPoint -> TxOut -> m ()
delOutput :: forall (m :: * -> *).
MonadImport m =>
BlockRef -> OutPoint -> TxOut -> m ()
delOutput = forall (m :: * -> *).
MonadImport m =>
Bool -> BlockRef -> OutPoint -> TxOut -> m ()
modOutput Bool
False
modOutput :: MonadImport m => Bool -> BlockRef -> OutPoint -> TxOut -> m ()
modOutput :: forall (m :: * -> *).
MonadImport m =>
Bool -> BlockRef -> OutPoint -> TxOut -> m ()
modOutput Bool
add BlockRef
br OutPoint
op TxOut
o = do
m ()
mod_unspent
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Address
ma forall a b. (a -> b) -> a -> b
$ \Address
a -> do
Address -> Unspent -> m ()
mod_addr_unspent Address
a Unspent
u
forall (m :: * -> *).
MonadImport m =>
Bool -> Bool -> Address -> UnixTime -> m ()
modBalance (BlockRef -> Bool
confirmed BlockRef
br) Bool
add Address
a (TxOut -> UnixTime
outValue TxOut
o)
forall (m :: * -> *).
MonadImport m =>
Address -> (UnixTime -> UnixTime) -> m ()
modifyReceived Address
a UnixTime -> UnixTime
v
where
v :: UnixTime -> UnixTime
v
| Bool
add = (forall a. Num a => a -> a -> a
+ TxOut -> UnixTime
outValue TxOut
o)
| Bool
otherwise = forall a. Num a => a -> a -> a
subtract (TxOut -> UnixTime
outValue TxOut
o)
ma :: Maybe Address
ma = forall a b. Either a b -> Maybe b
eitherToMaybe (ByteString -> Either String Address
scriptToAddressBS (TxOut -> ByteString
scriptOutput TxOut
o))
u :: Unspent
u =
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 = forall (m :: * -> *). StoreWrite m => Unspent -> m ()
insertUnspent Unspent
u
| Bool
otherwise = forall (m :: * -> *). StoreWrite m => OutPoint -> m ()
deleteUnspent OutPoint
op
mod_addr_unspent :: Address -> Unspent -> m ()
mod_addr_unspent
| Bool
add = forall (m :: * -> *). StoreWrite m => Address -> Unspent -> m ()
insertAddrUnspent
| Bool
otherwise = forall (m :: * -> *). StoreWrite m => Address -> Unspent -> m ()
deleteAddrUnspent
delOutputs :: MonadImport m => BlockRef -> Tx -> m ()
delOutputs :: forall (m :: * -> *). MonadImport m => BlockRef -> Tx -> m ()
delOutputs BlockRef
br Tx
tx =
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Word32
0 ..] (Tx -> [TxOut]
txOut Tx
tx)) forall a b. (a -> b) -> a -> b
$ \(Word32
i, TxOut
o) -> do
let op :: OutPoint
op = TxHash -> Word32 -> OutPoint
OutPoint (Tx -> TxHash
txHash Tx
tx) Word32
i
forall (m :: * -> *).
MonadImport m =>
BlockRef -> OutPoint -> TxOut -> m ()
delOutput BlockRef
br OutPoint
op TxOut
o
getImportTxData :: MonadImport m => TxHash -> m TxData
getImportTxData :: forall (m :: * -> *). MonadImport m => TxHash -> m TxData
getImportTxData TxHash
th =
forall (m :: * -> *). StoreReadBase m => TxHash -> m (Maybe TxData)
getActiveTxData TxHash
th forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe TxData
Nothing -> do
$(logDebugS) Text
"BlockStore" forall a b. (a -> b) -> a -> b
$ Text
"Tx not found: " forall a. Semigroup a => a -> a -> a
<> TxHash -> Text
txHashToHex TxHash
th
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ImportException
TxNotFound
Just TxData
d -> forall (m :: * -> *) a. Monad m => a -> m a
return TxData
d
getTxOut :: Word32 -> Tx -> Maybe TxOut
getTxOut :: Word32 -> Tx -> Maybe TxOut
getTxOut Word32
i Tx
tx = do
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
i forall a. Ord a => a -> a -> Bool
< forall (t :: * -> *) a. Foldable t => t a -> Int
length (Tx -> [TxOut]
txOut Tx
tx))
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Tx -> [TxOut]
txOut Tx
tx forall a. [a] -> Int -> a
!! forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
i
insertSpender :: MonadImport m => OutPoint -> Spender -> m ()
insertSpender :: forall (m :: * -> *). MonadImport m => OutPoint -> Spender -> m ()
insertSpender OutPoint
op Spender
s = do
TxData
td <- forall (m :: * -> *). MonadImport m => TxHash -> m TxData
getImportTxData (OutPoint -> TxHash
outPointHash OutPoint
op)
let p :: IntMap Spender
p = TxData -> IntMap Spender
txDataSpenders TxData
td
p' :: IntMap Spender
p' = forall a. Int -> a -> IntMap a -> IntMap a
I.insert (forall a b. (Integral a, Num b) => a -> b
fromIntegral (OutPoint -> Word32
outPointIndex OutPoint
op)) Spender
s IntMap Spender
p
td' :: TxData
td' = TxData
td {txDataSpenders :: IntMap Spender
txDataSpenders = IntMap Spender
p'}
forall (m :: * -> *). StoreWrite m => TxData -> m ()
insertTx TxData
td'
deleteSpender :: MonadImport m => OutPoint -> m ()
deleteSpender :: forall (m :: * -> *). MonadImport m => OutPoint -> m ()
deleteSpender OutPoint
op = do
TxData
td <- forall (m :: * -> *). MonadImport m => TxHash -> m TxData
getImportTxData (OutPoint -> TxHash
outPointHash OutPoint
op)
let p :: IntMap Spender
p = TxData -> IntMap Spender
txDataSpenders TxData
td
p' :: IntMap Spender
p' = forall a. Int -> IntMap a -> IntMap a
I.delete (forall a b. (Integral a, Num b) => a -> b
fromIntegral (OutPoint -> Word32
outPointIndex OutPoint
op)) IntMap Spender
p
td' :: TxData
td' = TxData
td {txDataSpenders :: IntMap Spender
txDataSpenders = IntMap Spender
p'}
forall (m :: * -> *). StoreWrite m => TxData -> m ()
insertTx TxData
td'
spendOutput :: MonadImport m => TxHash -> Word32 -> OutPoint -> m ()
spendOutput :: forall (m :: * -> *).
MonadImport m =>
TxHash -> Word32 -> OutPoint -> m ()
spendOutput TxHash
th Word32
ix OutPoint
op = do
Unspent
u <-
forall (m :: * -> *).
StoreReadBase m =>
OutPoint -> m (Maybe Unspent)
getUnspent OutPoint
op forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Unspent
u -> forall (m :: * -> *) a. Monad m => a -> m a
return Unspent
u
Maybe Unspent
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Could not find UTXO to spend: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show OutPoint
op
forall (m :: * -> *). StoreWrite m => OutPoint -> m ()
deleteUnspent OutPoint
op
forall (m :: * -> *). MonadImport m => OutPoint -> Spender -> m ()
insertSpender OutPoint
op (TxHash -> Word32 -> Spender
Spender TxHash
th Word32
ix)
let pk :: ByteString
pk = Unspent -> ByteString
unspentScript Unspent
u
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ByteString -> Either String Address
scriptToAddressBS ByteString
pk) forall a b. (a -> b) -> a -> b
$ \Address
a -> do
forall (m :: * -> *).
MonadImport m =>
Bool -> Address -> UnixTime -> m ()
decreaseBalance
(BlockRef -> Bool
confirmed (Unspent -> BlockRef
unspentBlock Unspent
u))
Address
a
(Unspent -> UnixTime
unspentAmount Unspent
u)
forall (m :: * -> *). StoreWrite m => Address -> Unspent -> m ()
deleteAddrUnspent Address
a Unspent
u
unspendOutputs :: MonadImport m => Tx -> m ()
unspendOutputs :: forall (m :: * -> *). MonadImport m => Tx -> m ()
unspendOutputs = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). MonadImport m => OutPoint -> m ()
unspendOutput forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx -> [OutPoint]
prevOuts
unspendOutput :: MonadImport m => OutPoint -> m ()
unspendOutput :: forall (m :: * -> *). MonadImport m => OutPoint -> m ()
unspendOutput OutPoint
op = do
TxData
t <-
forall (m :: * -> *). StoreReadBase m => TxHash -> m (Maybe TxData)
getActiveTxData (OutPoint -> TxHash
outPointHash OutPoint
op) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe TxData
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Could not find tx data: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (OutPoint -> TxHash
outPointHash OutPoint
op)
Just TxData
t -> forall (m :: * -> *) a. Monad m => a -> m a
return TxData
t
let o :: TxOut
o =
forall a. a -> Maybe a -> a
fromMaybe
(forall a. HasCallStack => String -> a
error (String
"Could not find output: " forall a. Semigroup a => a -> a -> a
<> 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 = forall a b. Either a b -> Maybe b
eitherToMaybe (ByteString -> Either String Address
scriptToAddressBS (TxOut -> ByteString
scriptOutput TxOut
o))
u :: Unspent
u =
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
}
forall (m :: * -> *). MonadImport m => OutPoint -> m ()
deleteSpender OutPoint
op
forall (m :: * -> *). StoreWrite m => Unspent -> m ()
insertUnspent Unspent
u
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Address
m forall a b. (a -> b) -> a -> b
$ \Address
a -> do
forall (m :: * -> *). StoreWrite m => Address -> Unspent -> m ()
insertAddrUnspent Address
a Unspent
u
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 :: forall (m :: * -> *).
MonadImport m =>
Address -> (UnixTime -> UnixTime) -> m ()
modifyReceived Address
a UnixTime -> UnixTime
f = do
Balance
b <- forall (m :: * -> *). StoreReadBase m => Address -> m Balance
getDefaultBalance Address
a
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 :: forall (m :: * -> *).
MonadImport m =>
Bool -> Address -> UnixTime -> m ()
decreaseBalance Bool
conf = forall (m :: * -> *).
MonadImport m =>
Bool -> Bool -> Address -> UnixTime -> m ()
modBalance Bool
conf Bool
False
increaseBalance :: MonadImport m => Bool -> Address -> Word64 -> m ()
increaseBalance :: forall (m :: * -> *).
MonadImport m =>
Bool -> Address -> UnixTime -> m ()
increaseBalance Bool
conf = forall (m :: * -> *).
MonadImport m =>
Bool -> Bool -> Address -> UnixTime -> m ()
modBalance Bool
conf Bool
True
modBalance ::
MonadImport m =>
Bool ->
Bool ->
Address ->
Word64 ->
m ()
modBalance :: forall (m :: * -> *).
MonadImport m =>
Bool -> Bool -> Address -> UnixTime -> m ()
modBalance Bool
conf Bool
add Address
a UnixTime
val = do
Balance
b <- forall (m :: * -> *). StoreReadBase m => Address -> m Balance
getDefaultBalance Address
a
forall (m :: * -> *). StoreWrite m => Balance -> m ()
setBalance forall a b. (a -> b) -> a -> b
$ (Balance -> Balance
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. Balance -> Balance
f) Balance
b
where
g :: Balance -> Balance
g Balance
b = Balance
b {balanceUnspentCount :: UnixTime
balanceUnspentCount = UnixTime -> UnixTime -> UnixTime
m UnixTime
1 (Balance -> UnixTime
balanceUnspentCount Balance
b)}
f :: Balance -> Balance
f 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 = forall a. Num a => a -> a -> a
(+)
| Bool
otherwise = forall a. Num a => a -> a -> a
subtract
modAddressCount :: MonadImport m => Bool -> Address -> m ()
modAddressCount :: forall (m :: * -> *). MonadImport m => Bool -> Address -> m ()
modAddressCount Bool
add Address
a = do
Balance
b <- forall (m :: * -> *). StoreReadBase m => Address -> m Balance
getDefaultBalance Address
a
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 = (forall a. Num a => a -> a -> a
+ UnixTime
1)
| Bool
otherwise = forall a. Num a => a -> a -> a
subtract UnixTime
1
txOutAddrs :: [TxOut] -> [Address]
txOutAddrs :: [TxOut] -> [Address]
txOutAddrs = forall a. (Eq a, Hashable a) => [a] -> [a]
nub' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [Either a b] -> [b]
rights forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> Either String Address
scriptToAddressBS forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut -> ByteString
scriptOutput)
txInAddrs :: [Prev] -> [Address]
txInAddrs :: [Prev] -> [Address]
txInAddrs = forall a. (Eq a, Hashable a) => [a] -> [a]
nub' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [Either a b] -> [b]
rights forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> Either String Address
scriptToAddressBS forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prev -> ByteString
prevScript)
txDataAddresses :: TxData -> [Address]
txDataAddresses :: TxData -> [Address]
txDataAddresses TxData
t =
forall a. (Eq a, Hashable a) => [a] -> [a]
nub' forall a b. (a -> b) -> a -> b
$ [Prev] -> [Address]
txInAddrs [Prev]
prevs forall a. Semigroup a => a -> a -> a
<> [TxOut] -> [Address]
txOutAddrs [TxOut]
outs
where
prevs :: [Prev]
prevs = forall a. IntMap a -> [a]
I.elems (TxData -> IntMap Prev
txDataPrevs TxData
t)
outs :: [TxOut]
outs = Tx -> [TxOut]
txOut (TxData -> Tx
txData TxData
t)
prevOuts :: Tx -> [OutPoint]
prevOuts :: Tx -> [OutPoint]
prevOuts Tx
tx = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= OutPoint
nullOutPoint) (forall a b. (a -> b) -> [a] -> [b]
map TxIn -> OutPoint
prevOutput (Tx -> [TxIn]
txIn Tx
tx))
testPresent :: StoreReadBase m => Tx -> m Bool
testPresent :: forall (m :: * -> *). StoreReadBase m => Tx -> m Bool
testPresent Tx
tx = forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). StoreReadBase m => TxHash -> m (Maybe TxData)
getActiveTxData (Tx -> TxHash
txHash Tx
tx)