haskoin-wallet-0.2.0: Network/Haskoin/Wallet/Transaction.hs
module Network.Haskoin.Wallet.Transaction
(
-- *Database transactions
txPage
, addrTxPage
, getTx
, getAccountTx
, importTx
, importNetTx
, signKeyRingTx
, createTx
, signOfflineTx
, getOfflineTxData
, killTxs
, reviveTx
, getPendingTxs
-- *Database blocks
, importMerkles
, getBestBlock
-- *Database coins and balances
, spendableCoins
, spendableCoinsSource
, accountBalance
, addressBalances
-- *Rescan
, resetRescan
-- *Helpers
, splitSelect
, splitUpdate
, splitDelete
, join2
, InCoinData(..)
) where
import Control.Arrow (second)
import Control.Monad (forM, forM_, when, liftM, unless)
import Control.Monad.Trans (MonadIO, liftIO)
import Control.Monad.Base (MonadBase)
import Control.Monad.Catch (MonadThrow)
import Control.Monad.Trans.Resource (MonadResource)
import Control.Exception (throwIO, throw)
import Data.Time (UTCTime, getCurrentTime)
import Data.Word (Word32, Word64)
import Data.Either (rights)
import Data.List ((\\), nub, nubBy, find)
import Data.List.Split (chunksOf)
import Data.Text (unpack)
import Data.Conduit (Source, mapOutput, ($$))
import Data.Maybe (isNothing, isJust, fromMaybe, listToMaybe)
import qualified Data.Map.Strict as M
( Map, toList, map, unionWith, fromListWith )
import Data.String.Conversions (cs)
import qualified Database.Persist as P
( Filter
, selectFirst
, deleteWhere, insertBy, insertMany_, PersistEntity
, PersistEntityBackend
)
import Database.Esqueleto
( Value(..), SqlQuery, SqlExpr, SqlBackend
, InnerJoin(..), LeftOuterJoin(..), OrderBy, update, sum_, groupBy
, select, from, where_, val, valList, sub_select, countRows, count
, orderBy, limit, asc, desc, set, offset, selectSource
, in_, unValue, not_, coalesceDefault, just, on
, case_, when_, then_, else_, distinct
, (^.), (=.), (==.), (&&.), (||.), (<.)
, (<=.), (>=.), (-.), (?.), (!=.)
-- Reexports from Database.Persist
, SqlPersistT, Entity(..)
, getBy, replace
)
import qualified Database.Esqueleto as E (isNothing, delete)
import Database.Esqueleto.Internal.Sql (SqlSelect)
import Network.Haskoin.Block
import Network.Haskoin.Transaction
import Network.Haskoin.Script
import Network.Haskoin.Crypto
import Network.Haskoin.Util
import Network.Haskoin.Constants
import Network.Haskoin.Node.STM
import Network.Haskoin.Node.HeaderTree
import Network.Haskoin.Wallet.KeyRing
import Network.Haskoin.Wallet.Model
import Network.Haskoin.Wallet.Types
import Network.Haskoin.Wallet.Database
-- Input coin type with transaction and address information
data InCoinData = InCoinData
{ inCoinDataCoin :: !(Entity KeyRingCoin)
, inCoinDataTx :: !KeyRingTx
, inCoinDataAddr :: !KeyRingAddr
}
instance Coin InCoinData where
coinValue (InCoinData (Entity _ c) _ _) = keyRingCoinValue c
-- Output coin type with address information
data OutCoinData = OutCoinData
{ outCoinDataAddr :: !(Entity KeyRingAddr)
, outCoinDataPos :: !KeyIndex
, outCoinDataValue :: !Word64
, outCoinDataScript :: !ScriptOutput
}
{- List transaction -}
-- | Get transactions by page
txPage :: MonadIO m
=> KeyRingAccountId -- ^ Account ID
-> PageRequest -- ^ Page request
-> SqlPersistT m ([KeyRingTx], Word32)
-- ^ Page result
txPage ai page@PageRequest{..}
| validPageRequest page = do
cntRes <- select $ from $ \t -> do
where_ $ t ^. KeyRingTxAccount ==. val ai
return countRows
let cnt = maybe 0 unValue $ listToMaybe cntRes
(d, m) = cnt `divMod` pageLen
maxPage = max 1 $ d + min 1 m
when (pageNum > maxPage) $ liftIO . throwIO $ WalletException $
unwords [ "Invalid page number", show pageNum ]
res <- liftM (map entityVal) $ select $ from $ \t -> do
where_ $ t ^. KeyRingTxAccount ==. val ai
let order = if pageReverse then asc else desc
orderBy [ order (t ^. KeyRingTxId) ]
limit $ fromIntegral pageLen
offset $ fromIntegral $ (pageNum - 1) * pageLen
return t
let f = if pageReverse then id else reverse
return (f res, maxPage)
| otherwise = liftIO . throwIO $ WalletException $
concat [ "Invalid page request"
, " (Page: ", show pageNum, ", Page size: ", show pageLen, ")"
]
addrTxPage :: MonadIO m
=> Entity KeyRingAccount -- ^ Account entity
-> KeyRingAddrId -- ^ Address Id
-> PageRequest -- ^ Page request
-> SqlPersistT m ([(KeyRingTx, BalanceInfo)], Word32)
addrTxPage (Entity ai _) addrI page@PageRequest{..}
| validPageRequest page = do
let joinSpentCoin c2 s =
c2 ?. KeyRingCoinAccount ==. s ?. KeyRingSpentCoinAccount
&&. c2 ?. KeyRingCoinHash ==. s ?. KeyRingSpentCoinHash
&&. c2 ?. KeyRingCoinPos ==. s ?. KeyRingSpentCoinPos
&&. c2 ?. KeyRingCoinAddr ==. just (val addrI)
joinSpent s t =
s ?. KeyRingSpentCoinSpendingTx ==. just (t ^. KeyRingTxId)
joinCoin c t =
c ?. KeyRingCoinTx ==. just (t ^. KeyRingTxId)
&&. c ?. KeyRingCoinAddr ==. just (val addrI)
joinAll t c c2 s = do
on $ joinSpentCoin c2 s
on $ joinSpent s t
on $ joinCoin c t
-- Find all the tids
tids <- liftM (map unValue) $ select $ distinct $ from $
\(t `LeftOuterJoin` c `LeftOuterJoin`
s `LeftOuterJoin` c2) -> do
joinAll t c c2 s
where_ ( t ^. KeyRingTxAccount ==. val ai
&&. ( not_ (E.isNothing (c ?. KeyRingCoinId))
||. not_ (E.isNothing (c2 ?. KeyRingCoinId))
)
)
orderBy [ asc (t ^. KeyRingTxId) ]
return $ t ^. KeyRingTxId
let cnt = fromIntegral $ length tids
(d, m) = cnt `divMod` pageLen
maxPage = max 1 $ d + min 1 m
when (pageNum > maxPage) $ liftIO . throwIO $ WalletException $
unwords [ "Invalid page number", show pageNum ]
let fOrd = if pageReverse then reverse else id
toDrop = fromIntegral $ (pageNum - 1) * pageLen
-- We call fOrd twice to reverse the page back to ASC
tidPage =
fOrd $ take (fromIntegral pageLen) $ drop toDrop $ fOrd tids
-- Use a sliptSelect query here with the exact tids to speed up the
-- query.
res <- splitSelect tidPage $ \tid ->
from $ \(t `LeftOuterJoin` c `LeftOuterJoin`
s `LeftOuterJoin` c2) -> do
joinAll t c c2 s
where_ $ t ^. KeyRingTxId `in_` valList tid
groupBy $ t ^. KeyRingTxId
orderBy [ asc (t ^. KeyRingTxId) ]
return ( t
-- Incoming value
, coalesceDefault [sum_ (c ?. KeyRingCoinValue)] (val 0)
-- Outgoing value
, coalesceDefault [sum_ (c2 ?. KeyRingCoinValue)] (val 0)
-- Number of new coins created
, count $ c ?. KeyRingCoinId
-- Number of coins spent
, count $ c2 ?. KeyRingCoinId
)
let f (t, Value inVal, Value outVal, Value newCount, Value spentCount) =
( entityVal t
, BalanceInfo
{ balanceInfoInBalance = floor (inVal :: Double)
, balanceInfoOutBalance = floor (outVal :: Double)
, balanceInfoCoins = newCount
, balanceInfoSpentCoins = spentCount
}
)
return (map f res, maxPage)
| otherwise = liftIO . throwIO $ WalletException $
concat [ "Invalid page request"
, " (Page: ", show pageNum, ", Page size: ", show pageLen, ")"
]
-- Helper function to get a transaction from the wallet database. The function
-- will look across all accounts and return the first available transaction. If
-- the transaction does not exist, this function will throw a wallet exception.
getTx :: MonadIO m => TxHash -> SqlPersistT m (Maybe Tx)
getTx txid = do
res <- select $ from $ \t -> do
where_ $ t ^. KeyRingTxHash ==. val txid
limit 1
return $ t ^. KeyRingTxTx
case res of
(Value tx:_) -> return $ Just tx
_ -> return Nothing
getAccountTx :: MonadIO m
=> KeyRingAccountId -> TxHash -> SqlPersistT m KeyRingTx
getAccountTx ai txid = do
res <- select $ from $ \t -> do
where_ ( t ^. KeyRingTxAccount ==. val ai
&&. t ^. KeyRingTxHash ==. val txid
)
return t
case res of
(Entity _ tx:_) -> return tx
_ -> liftIO . throwIO $ WalletException $ unwords
[ "Transaction does not exist:", cs $ txHashToHex txid ]
-- Helper function to get all the pending transactions from the database. It is
-- used to re-broadcast pending transactions in the wallet that have not been
-- included into blocks yet.
getPendingTxs :: MonadIO m => Int -> SqlPersistT m [TxHash]
getPendingTxs i =
liftM (map unValue) $ select $ from $ \t -> do
where_ $ t ^. KeyRingTxConfidence ==. val TxPending
limit $ fromIntegral i
return $ t ^. KeyRingTxHash
{- Transaction Import -}
-- | Import a transaction into the wallet from an unknown source. If the
-- transaction is standard, valid, all inputs are known and all inputs can be
-- spent, then the transaction will be imported as a network transaction.
-- Otherwise, the transaction will be imported into the local account as an
-- offline transaction.
importTx :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> Tx -- ^ Transaction to import
-> KeyRingAccountId -- ^ Account ID
-> SqlPersistT m ([KeyRingTx], [KeyRingAddr])
-- ^ New transactions and addresses created
importTx tx ai = importTx' tx ai =<< getInCoins tx (Just ai)
importTx' :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> Tx -- ^ Transaction to import
-> KeyRingAccountId -- ^ Account ID
-> [InCoinData] -- ^ Input coins
-> SqlPersistT m ([KeyRingTx], [KeyRingAddr])
-- ^ Transaction hash (after possible merges)
importTx' origTx ai origInCoins = do
-- Merge the transaction with any previously existing transactions
mergeResM <- mergeNoSigHashTxs ai origTx origInCoins
let tx = fromMaybe origTx mergeResM
origTxid = txHash origTx
txid = txHash tx
-- If the transaction was merged into a new transaction,
-- update the old hashes to the new ones. This allows us to
-- keep the spending information of our coins. It is thus possible
-- to spend partially signed multisignature transactions (as offline
-- transactions) even before all signatures have arrived.
inCoins <- if origTxid == txid then return origInCoins else do
-- Update transactions
update $ \t -> do
set t [ KeyRingTxHash =. val txid
, KeyRingTxTx =. val tx
]
where_ ( t ^. KeyRingTxAccount ==. val ai
&&. t ^. KeyRingTxHash ==. val origTxid
)
-- Update coins
update $ \t -> do
set t [ KeyRingCoinHash =. val txid ]
where_ ( t ^. KeyRingCoinAccount ==. val ai
&&. t ^. KeyRingCoinHash ==. val origTxid
)
let f (InCoinData c t x) = if keyRingTxHash t == origTxid
then InCoinData c t{ keyRingTxHash = txid, keyRingTxTx = tx } x
else InCoinData c t x
return $ map f origInCoins
spendingTxs <- getSpendingTxs tx (Just ai)
let validTx = verifyStdTx tx $ map toVerDat inCoins
validIn = length inCoins == length (txIn tx)
&& canSpendCoins inCoins spendingTxs False
if validIn && validTx
then importNetTx tx
else importOfflineTx tx ai inCoins spendingTxs
where
toVerDat (InCoinData (Entity _ c) t _) =
(keyRingCoinScript c, OutPoint (keyRingTxHash t) (keyRingCoinPos c))
-- Offline transactions are usually multisignature transactions requiring
-- additional signatures. This function will merge the signatures of
-- the same offline transactions together into one single transaction.
mergeNoSigHashTxs :: MonadIO m
=> KeyRingAccountId
-> Tx
-> [InCoinData]
-> SqlPersistT m (Maybe Tx)
mergeNoSigHashTxs ai tx inCoins = do
prevM <- getBy $ UniqueAccNoSig ai $ nosigTxHash tx
return $ case prevM of
Just (Entity _ prev) -> case keyRingTxConfidence prev of
TxOffline -> eitherToMaybe $
mergeTxs [tx, keyRingTxTx prev] outPoints
_ -> Nothing
-- Nothing to merge. Return the original transaction.
_ -> Nothing
where
buildOutpoint c t = OutPoint (keyRingTxHash t) (keyRingCoinPos c)
f (InCoinData (Entity _ c) t _) = (keyRingCoinScript c, buildOutpoint c t)
outPoints = map f inCoins
-- | Import an offline transaction into a specific account. Offline transactions
-- are imported either manually or from the wallet when building a partially
-- signed multisignature transaction. Offline transactions are only imported
-- into one specific account. They will not affect the input or output coins
-- of other accounts, including read-only accounts that may watch the same
-- addresses as this account.
--
-- We allow transactions to be imported manually by this function (unlike
-- `importNetTx` which imports only transactions coming from the network). This
-- means that it is possible to import completely crafted and invalid
-- transactions into the wallet. It is thus important to limit the scope of
-- those transactions to only the specific account in which it was imported.
--
-- This function will not broadcast these transactions to the network as we
-- have no idea if they are valid or not. Transactions are broadcast from the
-- transaction creation function and only if the transaction is complete.
importOfflineTx
:: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> Tx
-> KeyRingAccountId
-> [InCoinData]
-> [Entity KeyRingTx]
-> SqlPersistT m ([KeyRingTx], [KeyRingAddr])
importOfflineTx tx ai inCoins spendingTxs = do
-- Get all the new coins to be created by this transaction
outCoins <- getNewCoins tx $ Just ai
-- Only continue if the transaction is relevant to the account
when (null inCoins && null outCoins) err
-- Find the details of an existing transaction if it exists.
prevM <- liftM (fmap entityVal) $ getBy $ UniqueAccTx ai txid
-- Check if we can import the transaction
unless (canImport $ keyRingTxConfidence <$> prevM) err
-- Kill transactions that are spending our coins
killTxIds $ map entityKey spendingTxs
-- Create all the transaction records for this account.
-- This will spend the input coins and create the output coins
txsRes <- buildAccTxs tx TxOffline inCoins outCoins
-- use the addresses (refill the gap addresses)
newAddrs <- forM (nubBy sameKey $ map outCoinDataAddr outCoins) $
useAddress . entityVal
return (txsRes, concat newAddrs)
where
txid = txHash tx
canImport prevConfM =
-- We can only re-import offline txs through this function.
(isNothing prevConfM || prevConfM == Just TxOffline) &&
-- Check that all coins can be spent. We allow offline
-- coins to be spent by this function unlike importNetTx.
canSpendCoins inCoins spendingTxs True
sameKey e1 e2 = entityKey e1 == entityKey e2
err = liftIO . throwIO $ WalletException
"Could not import offline transaction"
-- | Import a transaction from the network into the wallet. This function
-- assumes transactions are imported in-order (parents first). It also assumes
-- that the confirmations always arrive after the transaction imports. This
-- function is idempotent.
--
-- When re-importing an existing transaction, this function will recompute
-- the inputs, outputs and transaction details for each account. A non-dead
-- transaction could be set to dead due to new inputs being double spent.
-- However, we do not allow dead transactions to be revived by reimporting them.
-- Transactions can only be revived if they make it into the main chain.
--
-- This function returns the network confidence of the imported transaction.
importNetTx
:: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> Tx -- Network transaction to import
-> SqlPersistT m ([KeyRingTx], [KeyRingAddr])
-- ^ Returns the new transactions and addresses created
importNetTx tx = do
-- Find all the coins spent by this transaction
inCoins <- getInCoins tx Nothing
-- Get all the new coins to be created by this transaction
outCoins <- getNewCoins tx Nothing
-- Only continue if the transaction is relevant to the wallet
if null inCoins && null outCoins then return ([],[]) else do
-- Update incomplete offline transactions when the completed
-- transaction comes in from the network.
updateNosigHash tx (nosigTxHash tx) txid
-- Get the transaction spending our coins
spendingTxs <- getSpendingTxs tx Nothing
-- Compute the confidence
let confidence | canSpendCoins inCoins spendingTxs False = TxPending
| otherwise = TxDead
-- Kill transactions that are spending our coins if we are not dead
when (confidence /= TxDead) $ killTxIds $ map entityKey spendingTxs
-- Create all the transaction records for this account.
-- This will spend the input coins and create the output coins
txRes <- buildAccTxs tx confidence inCoins outCoins
-- Use up the addresses of our new coins (replenish gap addresses)
newAddrs <- forM (nubBy sameKey $ map outCoinDataAddr outCoins) $
useAddress . entityVal
return (txRes, concat newAddrs)
where
sameKey e1 e2 = entityKey e1 == entityKey e2
txid = txHash tx
updateNosigHash :: MonadIO m => Tx -> TxHash -> TxHash -> SqlPersistT m ()
updateNosigHash tx nosig txid = do
res <- select $ from $ \t -> do
where_ ( t ^. KeyRingTxNosigHash ==. val nosig
&&. t ^. KeyRingTxHash !=. val txid
)
return $ t ^. KeyRingTxHash
let toUpdate = map unValue res
unless (null toUpdate) $ do
splitUpdate toUpdate $ \hs t -> do
set t [ KeyRingTxHash =. val txid
, KeyRingTxTx =. val tx
]
where_ $ t ^. KeyRingTxHash `in_` valList hs
splitUpdate toUpdate $ \hs c -> do
set c [ KeyRingCoinHash =. val txid ]
where_ $ c ^. KeyRingCoinHash `in_` valList hs
-- Check if the given coins can be spent.
canSpendCoins :: [InCoinData]
-> [Entity KeyRingTx]
-> Bool -- True for offline transactions
-> Bool
canSpendCoins inCoins spendingTxs offline =
all validCoin inCoins &&
all validSpend spendingTxs
where
-- We can only spend pending and building coins
validCoin (InCoinData _ t _)
| offline = keyRingTxConfidence t /= TxDead
| otherwise = keyRingTxConfidence t `elem` [TxPending, TxBuilding]
-- All transactions spending the same coins as us should be offline
validSpend = (== TxOffline) . keyRingTxConfidence . entityVal
-- Get the coins in the wallet related to the inputs of a transaction. You
-- can optionally provide an account to limit the returned coins to that
-- account only.
getInCoins :: MonadIO m
=> Tx
-> Maybe KeyRingAccountId
-> SqlPersistT m [InCoinData]
getInCoins tx aiM = do
res <- splitSelect ops $ \os -> from $ \(c `InnerJoin` t `InnerJoin` x) -> do
on $ x ^. KeyRingAddrId ==. c ^. KeyRingCoinAddr
on $ t ^. KeyRingTxId ==. c ^. KeyRingCoinTx
where_ $ case aiM of
Just ai ->
c ^. KeyRingCoinAccount ==. val ai &&. limitOutPoints c os
_ -> limitOutPoints c os
return (c, t, x)
return $ map (\(c, t, x) -> InCoinData c (entityVal t) (entityVal x)) res
where
ops = map prevOutput $ txIn tx
limitOutPoints c os = join2 $ map (f c) os
f c (OutPoint h i) =
c ^. KeyRingCoinHash ==. val h &&.
c ^. KeyRingCoinPos ==. val i
-- Find all the transactions that are spending the same coins as the given
-- transaction. You can optionally provide an account to limit the returned
-- transactions to that account only.
getSpendingTxs :: MonadIO m
=> Tx
-> Maybe KeyRingAccountId
-> SqlPersistT m [Entity KeyRingTx]
getSpendingTxs tx aiM
| null txInputs = return []
| otherwise =
splitSelect txInputs $ \ins -> from $ \(s `InnerJoin` t) -> do
on $ s ^. KeyRingSpentCoinSpendingTx ==. t ^. KeyRingTxId
-- Filter out the given transaction
let cond = t ^. KeyRingTxHash !=. val txid
-- Limit to only the input coins of the given tx
&&. limitSpent s ins
where_ $ case aiM of
Just ai -> cond &&. s ^. KeyRingSpentCoinAccount ==. val ai
_ -> cond
return t
where
txid = txHash tx
txInputs = map prevOutput $ txIn tx
limitSpent s ins = join2 $ map (f s) ins
f s (OutPoint h i) =
s ^. KeyRingSpentCoinHash ==. val h &&.
s ^. KeyRingSpentCoinPos ==. val i
-- Returns all the new coins that need to be created from a transaction.
-- Also returns the addresses associted with those coins.
getNewCoins :: MonadIO m
=> Tx
-> Maybe KeyRingAccountId
-> SqlPersistT m [OutCoinData]
getNewCoins tx aiM = do
-- Find all the addresses which are in the transaction outputs
addrs <- splitSelect uniqueAddrs $ \as -> from $ \x -> do
let cond = x ^. KeyRingAddrAddress `in_` valList as
where_ $ case aiM of
Just ai -> cond &&. x ^. KeyRingAddrAccount ==. val ai
_ -> cond
return x
return $ concatMap toCoins addrs
where
uniqueAddrs = nub $ map (\(addr,_,_,_) -> addr) outList
outList = rights $ map toDat txOutputs
txOutputs = zip (txOut tx) [0..]
toDat (out, pos) = getDataFromOutput out >>= \(addr, so) ->
return (addr, out, pos, so)
toCoins addrEnt@(Entity _ addr) =
let f (a,_,_,_) = a == keyRingAddrAddress addr
in map (toCoin addrEnt) $ filter f outList
toCoin addrEnt (_, out, pos, so) = OutCoinData
{ outCoinDataAddr = addrEnt
, outCoinDataPos = pos
, outCoinDataValue = outValue out
, outCoinDataScript = so
}
-- Decode an output and extract an output script and a recipient address
getDataFromOutput :: TxOut -> Either String (Address, ScriptOutput)
getDataFromOutput out = do
so <- decodeOutputBS $ scriptOutput out
addr <- scriptRecipient $ encodeOutput so
return (addr, so)
isCoinbaseTx :: Tx -> Bool
isCoinbaseTx (Tx _ tin _ _) =
length tin == 1 && outPointHash (prevOutput $ head tin) ==
"0000000000000000000000000000000000000000000000000000000000000000"
-- | Spend the given input coins. We also create dummy coins for the inputs
-- in a transaction that do not belong to us. This is to be able to detect
-- double spends when reorgs occur.
spendInputs :: MonadIO m
=> KeyRingAccountId
-> KeyRingTxId
-> Tx
-> SqlPersistT m ()
spendInputs ai ti tx = do
now <- liftIO getCurrentTime
-- Spend the coins by inserting values in KeyRingSpentCoin
P.insertMany_ $ map (buildSpentCoin now) txInputs
where
txInputs = map prevOutput $ txIn tx
buildSpentCoin now (OutPoint h p) =
KeyRingSpentCoin{ keyRingSpentCoinAccount = ai
, keyRingSpentCoinHash = h
, keyRingSpentCoinPos = p
, keyRingSpentCoinSpendingTx = ti
, keyRingSpentCoinCreated = now
}
-- Build account transaction for the given input and output coins
buildAccTxs :: MonadIO m
=> Tx
-> TxConfidence
-> [InCoinData]
-> [OutCoinData]
-> SqlPersistT m [KeyRingTx]
buildAccTxs tx confidence inCoins outCoins = do
now <- liftIO getCurrentTime
-- Group the coins by account
let grouped = groupCoinsByAccount inCoins outCoins
forM (M.toList grouped) $ \(ai, (is, os)) -> do
let atx = buildAccTx tx confidence ai is os now
-- Insert the new transaction. If it already exists, update the
-- information with the newly computed values. Also make sure that the
-- confidence is set to the new value (it could have changed to TxDead).
Entity ti newAtx <- P.insertBy atx >>= \resE -> case resE of
Left (Entity ti prev) -> do
let prevConf = keyRingTxConfidence prev
newConf | confidence == TxDead = TxDead
| prevConf == TxBuilding = TxBuilding
| otherwise = confidence
-- If the transaction already exists, preserve confirmation data
let newAtx = atx
{ keyRingTxConfidence = newConf
, keyRingTxConfirmedBy = keyRingTxConfirmedBy prev
, keyRingTxConfirmedHeight = keyRingTxConfirmedHeight prev
, keyRingTxConfirmedDate = keyRingTxConfirmedDate prev
}
replace ti newAtx
-- Spend inputs only if the previous transaction was dead
when (newConf /= TxDead && prevConf == TxDead) $
spendInputs ai ti tx
-- If the transaction changed from non-dead to dead, kill it.
-- This will remove spent coins and child transactions.
when (prevConf /= TxDead && newConf == TxDead) $ killTxIds [ti]
return (Entity ti newAtx)
Right ti -> do
when (confidence /= TxDead) $ spendInputs ai ti tx
return (Entity ti atx)
-- Insert the output coins with updated accTx key
let newOs = map (toCoin ai ti now) os
forM_ newOs $ \c -> P.insertBy c >>= \resE -> case resE of
Left (Entity ci _) -> replace ci c
_ -> return ()
-- Return the new transaction record
return newAtx
where
toCoin ai accTxId now (OutCoinData addrEnt pos vl so) = KeyRingCoin
{ keyRingCoinAccount = ai
, keyRingCoinHash = txHash tx
, keyRingCoinPos = pos
, keyRingCoinTx = accTxId
, keyRingCoinValue = vl
, keyRingCoinScript = so
, keyRingCoinAddr = entityKey addrEnt
, keyRingCoinCreated = now
}
-- | Build an account transaction given the input and output coins relevant to
-- this specific account. An account transaction contains the details of how a
-- transaction affects one particular account (value sent to and from the
-- account). The first value is Maybe an existing transaction in the database
-- which is used to get the existing confirmation values.
buildAccTx :: Tx
-> TxConfidence
-> KeyRingAccountId
-> [InCoinData]
-> [OutCoinData]
-> UTCTime
-> KeyRingTx
buildAccTx tx confidence ai inCoins outCoins now = KeyRingTx
{ keyRingTxAccount = ai
, keyRingTxHash = txHash tx
-- This is a hash of the transaction excluding signatures. This allows us
-- to track the evolution of offline transactions as we add more signatures
-- to them.
, keyRingTxNosigHash = nosigTxHash tx
, keyRingTxType = txType
, keyRingTxInValue = inVal
, keyRingTxOutValue = outVal
, keyRingTxInputs =
let f h i (InCoinData (Entity _ c) t _) =
keyRingTxHash t == h && keyRingCoinPos c == i
toInfo (a, OutPoint h i) = case find (f h i) inCoins of
Just (InCoinData (Entity _ c) _ _) ->
AddressInfo a (Just $ keyRingCoinValue c) True
_ -> AddressInfo a Nothing False
in map toInfo allInAddrs
, keyRingTxOutputs =
let toInfo (a,i,v) = AddressInfo a (Just v) $ ours i
ours i = isJust $ find ((== i) . outCoinDataPos) outCoins
in map toInfo allOutAddrs \\ changeAddrs
, keyRingTxChange = changeAddrs
, keyRingTxTx = tx
, keyRingTxIsCoinbase = isCoinbaseTx tx
, keyRingTxConfidence = confidence
-- Reuse the confirmation information of the existing transaction if
-- we have it.
, keyRingTxConfirmedBy = Nothing
, keyRingTxConfirmedHeight = Nothing
, keyRingTxConfirmedDate = Nothing
, keyRingTxCreated = now
}
where
-- The value going into the account is the sum of the output coins
inVal = sum $ map outCoinDataValue outCoins
-- The value going out of the account is the sum on the input coins
outVal = sum $ map coinValue inCoins
allMyCoins = length inCoins == length (txIn tx) &&
length outCoins == length (txOut tx)
txType
-- If all the coins belong to the same account, it is a self
-- transaction (even if a fee was payed).
| allMyCoins = TxSelf
-- This case can happen in complex transactions where the total
-- input/output sum for a given account is 0. In this case, we count
-- that transaction as a TxSelf. This should not happen with simple
-- transactions.
| inVal == outVal = TxSelf
| inVal > outVal = TxIncoming
| otherwise = TxOutgoing
-- List of all the decodable input addresses in the transaction
allInAddrs =
let f inp = do
addr <- scriptSender =<< decodeToEither (scriptInput inp)
return (addr, prevOutput inp)
in rights $ map f $ txIn tx
-- List of all the decodable output addresses in the transaction
allOutAddrs =
let f op i = do
addr <- scriptRecipient =<< decodeToEither (scriptOutput op)
return (addr, i, outValue op)
in rights $ zipWith f (txOut tx) [0..]
changeAddrs
| txType == TxIncoming = []
| otherwise =
let isInternal = (== AddressInternal) . keyRingAddrType
. entityVal . outCoinDataAddr
f = keyRingAddrAddress . entityVal . outCoinDataAddr
toInfo c = AddressInfo (f c) (Just $ outCoinDataValue c) True
in map toInfo $ filter isInternal outCoins
-- Group all the input and outputs coins from the same account together.
groupCoinsByAccount
:: [InCoinData]
-> [OutCoinData]
-> M.Map KeyRingAccountId ([InCoinData], [OutCoinData])
groupCoinsByAccount inCoins outCoins =
M.unionWith merge inMap outMap
where
-- Build a map from accounts -> (inCoins, outCoins)
f coin@(InCoinData _ t _) = (keyRingTxAccount t, [coin])
g coin = (keyRingAddrAccount $ entityVal $ outCoinDataAddr coin, [coin])
merge (is, _) (_, os) = (is, os)
inMap = M.map (\is -> (is, [])) $ M.fromListWith (++) $ map f inCoins
outMap = M.map (\os -> ([], os)) $ M.fromListWith (++) $ map g outCoins
-- Kill transactions and their child transactions by ids.
killTxIds :: MonadIO m => [KeyRingTxId] -> SqlPersistT m ()
killTxIds txIds = do
-- Find all the transactions spending the coins of these transactions
-- (Find all the child transactions)
childs <- splitSelect txIds $ \ts -> from $ \(t `InnerJoin` s) -> do
on ( s ^. KeyRingSpentCoinAccount ==. t ^. KeyRingTxAccount
&&. s ^. KeyRingSpentCoinHash ==. t ^. KeyRingTxHash
)
where_ $ t ^. KeyRingTxId `in_` valList ts
return $ s ^. KeyRingSpentCoinSpendingTx
-- Kill these transactions
splitUpdate txIds $ \ts t -> do
set t [ KeyRingTxConfidence =. val TxDead ]
where_ $ t ^. KeyRingTxId `in_` valList ts
-- This transaction doesn't spend any coins
splitDelete txIds $ \ts -> from $ \s ->
where_ $ s ^. KeyRingSpentCoinSpendingTx `in_` valList ts
-- Recursively kill all the child transactions.
-- (Recurse at the end in case there are closed loops)
unless (null childs) $ killTxIds $ nub $ map unValue childs
-- Kill transactions and their child transactions by hashes.
killTxs :: MonadIO m => [TxHash] -> SqlPersistT m ()
killTxs txHashes = do
res <- splitSelect txHashes $ \hs -> from $ \t -> do
where_ $ t ^. KeyRingTxHash `in_` valList hs
return $ t ^. KeyRingTxId
killTxIds $ map unValue res
{- Confirmations -}
importMerkles :: MonadIO m
=> BlockChainAction
-> [MerkleTxs]
-> SqlPersistT m ()
importMerkles action expTxsLs =
when (isBestChain action || isChainReorg action) $ do
case action of
ChainReorg _ os _ ->
-- Unconfirm transactions from the old chain.
let hs = map (Just . nodeBlockHash) os
in splitUpdate hs $ \h t -> do
set t [ KeyRingTxConfidence =. val TxPending
, KeyRingTxConfirmedBy =. val Nothing
, KeyRingTxConfirmedHeight =. val Nothing
, KeyRingTxConfirmedDate =. val Nothing
]
where_ $ t ^. KeyRingTxConfirmedBy `in_` valList h
_ -> return ()
-- Find all the dead transactions which need to be revived
deadTxs <- splitSelect (concat expTxsLs) $ \ts -> from $ \t -> do
where_ ( t ^. KeyRingTxHash `in_` valList ts
&&. t ^. KeyRingTxConfidence ==. val TxDead
)
return $ t ^. KeyRingTxTx
-- Revive dead transactions (in no particular order)
forM_ deadTxs $ reviveTx . unValue
-- Confirm the transactions
forM_ (zip (actionNodes action) expTxsLs) $ \(node, hs) ->
splitUpdate hs $ \h t -> do
set t [ KeyRingTxConfidence =. val TxBuilding
, KeyRingTxConfirmedBy =. val (Just (nodeBlockHash node))
, KeyRingTxConfirmedHeight =.
val (Just (nodeHeaderHeight node))
, KeyRingTxConfirmedDate =.
val (Just (blockTimestamp $ nodeHeader node))
]
where_ $ t ^. KeyRingTxHash `in_` valList h
-- Update the best height in the wallet (used to compute the number
-- of confirmations of transactions)
case reverse $ actionNodes action of
(best:_) ->
setBestBlock (nodeBlockHash best) (nodeHeaderHeight best)
_ -> return ()
-- Helper function to set the best block and best block height in the DB.
setBestBlock :: MonadIO m => BlockHash -> Word32 -> SqlPersistT m ()
setBestBlock bid i = update $ \t -> set t [ KeyRingConfigBlock =. val bid
, KeyRingConfigHeight =. val i
]
-- Helper function to get the best block and best block height from the DB
getBestBlock :: MonadIO m => SqlPersistT m (BlockHash, Word32)
getBestBlock = do
cfgM <- liftM (fmap entityVal) $ P.selectFirst [] []
return $ case cfgM of
Just KeyRingConfig{..} -> (keyRingConfigBlock, keyRingConfigHeight)
Nothing -> throw $ WalletException $ unwords
[ "Could not get the best block."
, "Wallet database is probably not initialized"
]
-- Revive a dead transaction. All transactions that are in conflict with this
-- one will be killed.
reviveTx :: MonadIO m => Tx -> SqlPersistT m ()
reviveTx tx = do
-- Kill all transactions spending our coins
spendingTxs <- getSpendingTxs tx Nothing
killTxIds $ map entityKey spendingTxs
-- Find all the KeyRingTxId that have to be revived
ids <- select $ from $ \t -> do
where_ ( t ^. KeyRingTxHash ==. val (txHash tx)
&&. t ^. KeyRingTxConfidence ==. val TxDead
)
return (t ^. KeyRingTxAccount, t ^. KeyRingTxId)
-- Spend the inputs for all our transactions
forM_ ids $ \(Value ai, Value ti) -> spendInputs ai ti tx
-- Update the transactions
splitUpdate (map (unValue . snd) ids) $ \is t -> do
set t [ KeyRingTxConfidence =. val TxPending
, KeyRingTxConfirmedBy =. val Nothing
, KeyRingTxConfirmedHeight =. val Nothing
, KeyRingTxConfirmedDate =. val Nothing
]
where_ $ t ^. KeyRingTxId `in_` valList is
{- Transaction creation and signing (local wallet functions) -}
-- | Create a transaction sending some coins to a list of recipient addresses.
createTx :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> KeyRing -- ^ KeyRing
-> Entity KeyRingAccount -- ^ Account Entity
-> [(Address,Word64)] -- ^ List of recipient addresses and amounts
-> Word64 -- ^ Fee per 1000 bytes
-> Word32 -- ^ Minimum confirmations
-> Bool -- ^ Should fee be paid by recipient
-> Bool -- ^ Should the transaction be signed
-> SqlPersistT m (KeyRingTx, [KeyRingAddr])
-- ^ (New transaction hash, Completed flag)
createTx keyRing accE@(Entity ai acc) dests fee minConf rcptFee sign = do
-- Build an unsigned transaction from the given recipient values and fee
(unsignedTx, inCoins) <- buildUnsignedTx accE dests fee minConf rcptFee
-- Sign our new transaction if signing was requested
let dat = map toCoinSignData inCoins
tx | sign = signOfflineTx keyRing acc unsignedTx dat
| otherwise = unsignedTx
-- Import the transaction in the wallet either as a network transaction if
-- it is complete, or as an offline transaction otherwise.
(res, newAddrs) <- importTx' tx ai inCoins
case res of
(txRes:_) -> return (txRes, newAddrs)
_ -> liftIO . throwIO $ WalletException
"Error while importing the new transaction"
toCoinSignData :: InCoinData -> CoinSignData
toCoinSignData (InCoinData (Entity _ c) t x) =
CoinSignData (OutPoint (keyRingTxHash t) (keyRingCoinPos c))
(keyRingCoinScript c)
(keyRingAddrDerivation x)
-- Build an unsigned transaction given a list of recipients and a fee. Returns
-- the unsigned transaction together with the input coins that have been
-- selected or spending.
buildUnsignedTx
:: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> Entity KeyRingAccount
-> [(Address, Word64)]
-> Word64
-> Word32
-> Bool
-> SqlPersistT m (Tx, [InCoinData])
buildUnsignedTx _ [] _ _ _ = liftIO . throwIO $ WalletException
"buildUnsignedTx: No transaction recipients have been provided"
buildUnsignedTx accE@(Entity ai acc) origDests origFee minConf rcptFee = do
let p = case keyRingAccountType acc of
AccountMultisig _ m n -> (m, n)
_ -> throw . WalletException $ "Invalid account type"
fee = if rcptFee then 0 else origFee
sink | isMultisigAccount acc = chooseMSCoinsSink tot fee p True
| otherwise = chooseCoinsSink tot fee True
-- TODO: Add more policies like confirmations or coin age
-- Sort coins by their values in descending order
orderPolicy c _ = [desc $ c ^. KeyRingCoinValue]
-- Find the spendable coins in the given account with the required number
-- of minimum confirmations.
selectRes <- spendableCoinsSource ai minConf orderPolicy $$ sink
-- Find a selection of spendable coins that matches our target value
let (selected, change) = either (throw . WalletException) id selectRes
totFee | isMultisigAccount acc = getMSFee origFee p (length selected)
| otherwise = getFee origFee (length selected)
-- Subtract fees from first destination if rcptFee
value = snd $ head origDests
-- First output must not be dust after deducting fees
when (rcptFee && value < totFee + 5430) $ throw $ WalletException
"First recipient cannot cover transaction fees"
-- Subtract fees from first destination if rcptFee
let dests | rcptFee =
second (const $ value - totFee) (head origDests) :
tail origDests
| otherwise = origDests
-- Make sure the first recipient has enough funds to cover the fee
when (snd (head dests) <= 0) $ throw $
WalletException "Transaction fees too high"
-- If the change amount is not dust, we need to add a change address to
-- our list of recipients.
-- TODO: Put the dust value in a constant somewhere. We also need a more
-- general way of detecting dust such as our transactions are not
-- rejected by full nodes.
allDests <- if change < 5430
then return dests
else addChangeAddr change dests
case buildAddrTx (map toOutPoint selected) $ map toBase58 allDests of
Right tx -> return (tx, selected)
Left err -> liftIO . throwIO $ WalletException err
where
tot = sum $ map snd origDests
toBase58 (a, v) = (addrToBase58 a, v)
toOutPoint (InCoinData (Entity _ c) t _) =
OutPoint (keyRingTxHash t) (keyRingCoinPos c)
addChangeAddr change dests = do
as <- unusedAddresses accE AddressInternal
case as of
(a:_) -> do
-- Use the address to prevent reusing it again
_ <- useAddress a
-- TODO: Randomize the change position
return $ (keyRingAddrAddress a, change) : dests
_ -> liftIO . throwIO $ WalletException
"No unused addresses available"
signKeyRingTx :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> KeyRing -> Entity KeyRingAccount -> TxHash
-> SqlPersistT m ([KeyRingTx], [KeyRingAddr])
signKeyRingTx keyRing (Entity ai acc) txid = do
(OfflineTxData tx dat, inCoins) <- getOfflineTxData ai txid
let signedTx = signOfflineTx keyRing acc tx dat
importTx' signedTx ai inCoins
getOfflineTxData
:: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> KeyRingAccountId
-> TxHash
-> SqlPersistT m (OfflineTxData, [InCoinData])
getOfflineTxData ai txid = do
txM <- getBy $ UniqueAccTx ai txid
case txM of
Just (Entity _ tx) -> do
unless (keyRingTxConfidence tx == TxOffline) $ liftIO . throwIO $
WalletException "Can only sign offline transactions."
inCoins <- getInCoins (keyRingTxTx tx) $ Just ai
return
( OfflineTxData (keyRingTxTx tx) $ map toCoinSignData inCoins
, inCoins
)
_ -> liftIO . throwIO $ WalletException $ unwords
[ "Invalid txid", cs $ txHashToHex txid ]
-- Sign a transaction using a list of CoinSignData. This allows an offline
-- signer without access to the coins to sign a given transaction.
signOfflineTx :: KeyRing -- ^ KeyRing
-> KeyRingAccount -- ^ Account used for signing
-> Tx -- ^ Transaction to sign
-> [CoinSignData] -- ^ Input signing data
-> Tx
signOfflineTx keyRing acc tx coinSignData
-- Fail for read-only accounts
| isReadAccount acc = throw $ WalletException
"signOfflineTx is not supported on read-only accounts"
-- Sign the transaction deterministically
| otherwise = either (throw . WalletException) id $
signTx tx sigData $ map (toPrvKeyG . xPrvKey) prvKeys
where
-- Compute all the SigInputs
sigData = map (toSigData acc) coinSignData
-- Compute all the private keys
prvKeys = map (toPrvKey (keyRingMaster keyRing) acc) coinSignData
-- Build a SigInput from a CoinSignData
toSigData acc' (CoinSignData op so deriv) =
-- TODO: Here we override the SigHash to be SigAll False all the time.
-- Should we be more flexible?
SigInput so op (SigAll False) $
if isMultisigAccount acc
then Just $ getPathRedeem acc' deriv
else Nothing
toPrvKey master acc' (CoinSignData _ _ deriv) =
case keyRingAccountDerivation acc' of
Just root -> derivePath (root ++| deriv) master
_ -> throw $ WalletException $ unwords
[ "No derivation available in account"
, unpack $ keyRingAccountName acc'
]
-- Returns unspent coins that can be spent in an account that have a minimum
-- number of confirmations. Coinbase coins can only be spent after 100
-- confirmations.
spendableCoins
:: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> KeyRingAccountId -- ^ Account key
-> Word32 -- ^ Minimum confirmations
-> ( SqlExpr (Entity KeyRingCoin)
-> SqlExpr (Entity KeyRingTx)
-> [SqlExpr OrderBy]
)
-- ^ Coin ordering policy
-> SqlPersistT m [InCoinData] -- ^ Spendable coins
spendableCoins ai minConf orderPolicy =
liftM (map f) $ select $ spendableCoinsFrom ai minConf orderPolicy
where
f (c, t, x) = InCoinData c (entityVal t) (entityVal x)
spendableCoinsSource
:: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> KeyRingAccountId -- ^ Account key
-> Word32 -- ^ Minimum confirmations
-> ( SqlExpr (Entity KeyRingCoin)
-> SqlExpr (Entity KeyRingTx)
-> [SqlExpr OrderBy]
)
-- ^ Coin ordering policy
-> Source (SqlPersistT m) InCoinData
-- ^ Spendable coins
spendableCoinsSource ai minConf orderPolicy =
mapOutput f $ selectSource $ spendableCoinsFrom ai minConf orderPolicy
where
f (c, t, x) = InCoinData c (entityVal t) (entityVal x)
spendableCoinsFrom
:: KeyRingAccountId -- ^ Account key
-> Word32 -- ^ Minimum confirmations
-> ( SqlExpr (Entity KeyRingCoin)
-> SqlExpr (Entity KeyRingTx)
-> [SqlExpr OrderBy]
)
-- ^ Coin ordering policy
-> SqlQuery ( SqlExpr (Entity KeyRingCoin)
, SqlExpr (Entity KeyRingTx)
, SqlExpr (Entity KeyRingAddr)
)
spendableCoinsFrom ai minConf orderPolicy =
from $ \(c `InnerJoin` t `InnerJoin` x `LeftOuterJoin` s) -> do
-- Joins have to be set in reverse order !
-- Left outer join on spent coins
on ( s ?. KeyRingSpentCoinAccount ==. just (c ^. KeyRingCoinAccount)
&&. s ?. KeyRingSpentCoinHash ==. just (c ^. KeyRingCoinHash)
&&. s ?. KeyRingSpentCoinPos ==. just (c ^. KeyRingCoinPos)
)
on $ x ^. KeyRingAddrId ==. c ^. KeyRingCoinAddr
-- Inner join on coins and transactions
on $ t ^. KeyRingTxId ==. c ^. KeyRingCoinTx
where_ ( c ^. KeyRingCoinAccount ==. val ai
&&. t ^. KeyRingTxConfidence
`in_` valList [ TxPending, TxBuilding ]
-- We only want unspent coins
&&. E.isNothing (s ?. KeyRingSpentCoinId)
&&. limitConfirmations (Right t) minConf
)
orderBy (orderPolicy c t)
return (c, t, x)
-- If the current height is 200 and a coin was confirmed at height 198, then it
-- has 3 confirmations. So, if we require 3 confirmations, we want coins with a
-- confirmed height of 198 or less (200 - 3 + 1).
limitConfirmations :: Either (SqlExpr (Maybe (Entity KeyRingTx)))
(SqlExpr (Entity KeyRingTx))
-> Word32
-> SqlExpr (Value Bool)
limitConfirmations txE minconf
| minconf == 0 = limitCoinbase
| minconf < 100 = limitConfs minconf &&. limitCoinbase
| otherwise = limitConfs minconf
where
limitConfs i = case txE of
Left t -> t ?. KeyRingTxConfirmedHeight
<=. just (just (selectHeight -. val (i - 1)))
Right t -> t ^. KeyRingTxConfirmedHeight
<=. just (selectHeight -. val (i - 1))
-- Coinbase transactions require 100 confirmations
limitCoinbase = case txE of
Left t ->
not_ (coalesceDefault [t ?. KeyRingTxIsCoinbase] (val False)) ||.
limitConfs 100
Right t ->
not_ (t ^. KeyRingTxIsCoinbase) ||. limitConfs 100
selectHeight :: SqlExpr (Value Word32)
selectHeight = sub_select $ from $ \co -> do
limit 1
return $ co ^. KeyRingConfigHeight
{- Balances -}
accountBalance :: MonadIO m
=> KeyRingAccountId
-> Word32
-> Bool
-> SqlPersistT m Word64
accountBalance ai minconf offline = do
res <- select $ from $ \(c `InnerJoin`
t `LeftOuterJoin` s `LeftOuterJoin` st) -> do
on $ st ?. KeyRingTxId ==. s ?. KeyRingSpentCoinSpendingTx
on ( s ?. KeyRingSpentCoinAccount ==. just (c ^. KeyRingCoinAccount)
&&. s ?. KeyRingSpentCoinHash ==. just (c ^. KeyRingCoinHash)
&&. s ?. KeyRingSpentCoinPos ==. just (c ^. KeyRingCoinPos)
)
on $ t ^. KeyRingTxId ==. c ^. KeyRingCoinTx
let unspent = E.isNothing ( s ?. KeyRingSpentCoinId )
spentOffline = st ?. KeyRingTxConfidence ==. just (val TxOffline)
cond = c ^. KeyRingCoinAccount ==. val ai
&&. t ^. KeyRingTxConfidence `in_` valList validConfidence
-- For non-offline balances, we have to take into account
-- the coins which are spent by offline transactions.
&&. if offline then unspent else unspent ||. spentOffline
where_ $ if minconf == 0
then cond
else cond &&. limitConfirmations (Right t) minconf
return $ sum_ (c ^. KeyRingCoinValue)
case res of
(Value (Just s):_) -> return $ floor (s :: Double)
_ -> return 0
where
validConfidence = TxPending : TxBuilding : [ TxOffline | offline ]
addressBalances :: MonadIO m
=> Entity KeyRingAccount
-> KeyIndex
-> KeyIndex
-> AddressType
-> Word32
-> Bool
-> SqlPersistT m [(KeyIndex, BalanceInfo)]
addressBalances accE@(Entity ai _) iMin iMax addrType minconf offline = do
-- We keep our joins flat to improve performance in SQLite.
res <- select $ from $ \(x `LeftOuterJoin` c `LeftOuterJoin`
t `LeftOuterJoin` s `LeftOuterJoin` st) -> do
let joinCond = st ?. KeyRingTxId ==. s ?. KeyRingSpentCoinSpendingTx
-- Do not join the spending information for offline transactions if we
-- request the online balances. This will count the coin as unspent.
on $ if offline
then joinCond
else joinCond &&. st ?. KeyRingTxConfidence !=. just (val TxOffline)
on $ s ?. KeyRingSpentCoinAccount ==. c ?. KeyRingCoinAccount
&&. s ?. KeyRingSpentCoinHash ==. c ?. KeyRingCoinHash
&&. s ?. KeyRingSpentCoinPos ==. c ?. KeyRingCoinPos
let txJoin = t ?. KeyRingTxId ==. c ?. KeyRingCoinTx
&&. t ?. KeyRingTxConfidence `in_` valList validConfidence
on $ if minconf == 0
then txJoin
else txJoin &&. limitConfirmations (Left t) minconf
on $ c ?. KeyRingCoinAddr ==. just (x ^. KeyRingAddrId)
let limitIndex
| iMin == iMax = x ^. KeyRingAddrIndex ==. val iMin
| otherwise = x ^. KeyRingAddrIndex >=. val iMin
&&. x ^. KeyRingAddrIndex <=. val iMax
where_ ( x ^. KeyRingAddrAccount ==. val ai
&&. limitIndex
&&. x ^. KeyRingAddrIndex <. subSelectAddrCount accE addrType
&&. x ^. KeyRingAddrType ==. val addrType
)
groupBy $ x ^. KeyRingAddrIndex
let unspent = E.isNothing $ st ?. KeyRingTxId
invalidTx = E.isNothing $ t ?. KeyRingTxId
return ( x ^. KeyRingAddrIndex -- Address index
, sum_ $ case_
[ when_ invalidTx
then_ (val (Just 0))
] (else_ $ c ?. KeyRingCoinValue) -- Out value
, sum_ $ case_
[ when_ (unspent ||. invalidTx)
then_ (val (Just 0))
] (else_ $ c ?. KeyRingCoinValue) -- Out value
, count $ t ?. KeyRingTxId -- New coins
, count $ case_
[ when_ invalidTx
then_ (val Nothing)
] (else_ $ st ?. KeyRingTxId) -- Spent coins
)
return $ map f res
where
validConfidence = Just TxPending : Just TxBuilding :
[ Just TxOffline | offline ]
f (Value i, Value inM, Value outM, Value newC, Value spentC) =
let b = BalanceInfo
{ balanceInfoInBalance =
floor $ fromMaybe (0 :: Double) inM
, balanceInfoOutBalance =
floor $ fromMaybe (0 :: Double) outM
, balanceInfoCoins = newC
, balanceInfoSpentCoins = spentC
}
in (i, b)
{- Rescans -}
resetRescan :: MonadIO m => SqlPersistT m ()
resetRescan = do
P.deleteWhere ([] :: [P.Filter KeyRingCoin])
P.deleteWhere ([] :: [P.Filter KeyRingSpentCoin])
P.deleteWhere ([] :: [P.Filter KeyRingTx])
setBestBlock (headerHash genesisHeader) 0
{- Helpers -}
-- Join AND expressions with OR conditions in a binary way
join2 :: [SqlExpr (Value Bool)] -> SqlExpr (Value Bool)
join2 xs = case xs of
[] -> val False
[x] -> x
_ -> let (ls,rs) = splitAt (length xs `div` 2) xs
in join2 ls ||. join2 rs
splitSelect :: (SqlSelect a r, MonadIO m)
=> [t]
-> ([t] -> SqlQuery a)
-> SqlPersistT m [r]
splitSelect ts queryF =
liftM concat $ forM vals $ select . queryF
where
vals = chunksOf paramLimit ts
splitUpdate :: ( MonadIO m
, P.PersistEntity val
, P.PersistEntityBackend val ~ SqlBackend
)
=> [t]
-> ([t] -> SqlExpr (Entity val) -> SqlQuery ())
-> SqlPersistT m ()
splitUpdate ts updateF =
forM_ vals $ update . updateF
where
vals = chunksOf paramLimit ts
splitDelete :: MonadIO m => [t] -> ([t] -> SqlQuery ()) -> SqlPersistT m ()
splitDelete ts deleteF =
forM_ vals $ E.delete . deleteF
where
vals = chunksOf paramLimit ts