{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
module Network.Haskoin.Wallet.Transaction
(
txs
, addrTxs
, accTxsFromBlock
, getTx
, getAccountTx
, importTx
, importNetTx
, signAccountTx
, createWalletTx
, signOfflineTx
, getOfflineTxData
, killTxs
, reviveTx
, getPendingTxs
, deleteTx
, importMerkles
, walletBestBlock
, spendableCoins
, accountBalance
, addressBalances
, resetRescan
, InCoinData(..)
) where
import Control.Arrow (second)
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TBMChan (TBMChan, writeTBMChan)
import Control.Exception (throw, throwIO)
import Control.Monad (forM, forM_, unless, when)
import Control.Monad.Base (MonadBase)
import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.Trans (MonadIO, liftIO)
import Control.Monad.Trans.Resource (MonadResource)
import Data.Either (rights)
import Data.List (find, nub, nubBy, (\\))
import qualified Data.Map.Strict as M (Map, fromListWith, map,
toList, unionWith)
import Data.Maybe (fromMaybe, isJust, isNothing,
listToMaybe, mapMaybe)
import Data.String.Conversions (cs)
import Data.Time (UTCTime, getCurrentTime)
import Data.Word (Word32, Word64)
import Database.Esqueleto (Entity (..), InnerJoin (..),
LeftOuterJoin (..), OrderBy,
SqlExpr, SqlPersistT,
SqlQuery, Value (..), asc,
case_, coalesceDefault, count,
countDistinct, countRows,
delete, desc, distinct, else_,
from, get, getBy, groupBy,
in_, just, limit, not_, on,
orderBy, replace, select, set,
sub_select, sum_, then_,
unValue, update, val, valList,
when_, where_, (!=.), (&&.),
(-.), (<.), (<=.), (=.),
(==.), (>=.), (?.), (^.),
(||.))
import qualified Database.Esqueleto as E (isNothing)
import qualified Database.Persist as P (Filter, deleteWhere,
insertBy, selectFirst)
import Network.Haskoin.Block
import Network.Haskoin.Constants
import Network.Haskoin.Crypto
import Network.Haskoin.Node.HeaderTree
import Network.Haskoin.Node.STM
import Network.Haskoin.Script
import Network.Haskoin.Transaction
import Network.Haskoin.Util
import Network.Haskoin.Wallet.Accounts
import Network.Haskoin.Wallet.Model
import Network.Haskoin.Wallet.Types
data InCoinData = InCoinData
{ inCoinDataCoin :: !(Entity WalletCoin)
, inCoinDataTx :: !WalletTx
, inCoinDataAddr :: !WalletAddr
}
instance Coin InCoinData where
coinValue (InCoinData (Entity _ c) _ _) = walletCoinValue c
data OutCoinData = OutCoinData
{ outCoinDataAddr :: !(Entity WalletAddr)
, outCoinDataPos :: !KeyIndex
, outCoinDataValue :: !Word64
, outCoinDataScript :: !ScriptOutput
}
txs :: MonadIO m
=> Maybe TxConfidence
-> AccountId
-> ListRequest
-> SqlPersistT m ([WalletTx], Word32)
txs conf ai ListRequest{..} = do
[cnt] <- fmap (map unValue) $ select $ from $ \t -> do
cond t
return countRows
when (listOffset > 0 && listOffset >= cnt) $ throw $ WalletException
"Offset beyond end of data set"
res <- fmap (map entityVal) $ select $ from $ \t -> do
cond t
orderBy [ order (t ^. WalletTxId) ]
limitOffset listLimit listOffset
return t
return (res, cnt)
where
account t = t ^. WalletTxAccount ==. val ai
cond t = where_ $ case conf of
Just n -> account t &&. t ^. WalletTxConfidence ==. val n
Nothing -> account t
order = if listReverse then asc else desc
addrTxs :: MonadIO m
=> Entity Account
-> Entity WalletAddr
-> ListRequest
-> SqlPersistT m ([WalletTx], Word32)
addrTxs (Entity ai _) (Entity addrI WalletAddr{..}) ListRequest{..} = do
let joinSpentCoin c2 s =
c2 ?. WalletCoinAccount ==. s ?. SpentCoinAccount
&&. c2 ?. WalletCoinHash ==. s ?. SpentCoinHash
&&. c2 ?. WalletCoinPos ==. s ?. SpentCoinPos
&&. c2 ?. WalletCoinAddr ==. just (val addrI)
joinSpent s t =
s ?. SpentCoinSpendingTx ==. just (t ^. WalletTxId)
joinCoin c t =
c ?. WalletCoinTx ==. just (t ^. WalletTxId)
&&. c ?. WalletCoinAddr ==. just (val addrI)
joinAll t c c2 s = do
on $ joinSpentCoin c2 s
on $ joinSpent s t
on $ joinCoin c t
tables f = from $ \(t `LeftOuterJoin` c `LeftOuterJoin`
s `LeftOuterJoin` c2) -> f t c s c2
query t c s c2 = do
joinAll t c c2 s
where_ ( t ^. WalletTxAccount ==. val ai
&&. ( not_ (E.isNothing (c ?. WalletCoinId))
||. not_ (E.isNothing (c2 ?. WalletCoinId))
)
)
let order = if listReverse then asc else desc
orderBy [ order (t ^. WalletTxId) ]
cntRes <- select $ tables $ \t c s c2 -> do
query t c s c2
return $ countDistinct $ t ^. WalletTxId
let cnt = maybe 0 unValue $ listToMaybe cntRes
when (listOffset > 0 && listOffset >= cnt) $ throw $ WalletException
"Offset beyond end of data set"
res <- select $ distinct $ tables $ \t c s c2 -> do
query t c s c2
limitOffset listLimit listOffset
return t
return (map (updBals . entityVal) res, cnt)
where
agg = sum . mapMaybe addressInfoValue .
filter ((== walletAddrAddress) . addressInfoAddress)
updBals t =
let
input = agg $ walletTxInputs t
output = agg $ walletTxOutputs t
change = agg $ walletTxChange t
in
t { walletTxInValue = output + change
, walletTxOutValue = input
}
accTxsFromBlock :: (MonadIO m, MonadThrow m)
=> AccountId
-> BlockHeight
-> Word32
-> SqlPersistT m [WalletTx]
accTxsFromBlock ai bh n =
fmap (map entityVal) $ select $ from $ \t -> do
query t
orderBy [ asc (t ^. WalletTxConfirmedHeight), asc (t ^. WalletTxId) ]
return t
where
query t
| n == 0 = where_ $
t ^. WalletTxAccount ==. val ai &&.
t ^. WalletTxConfirmedHeight >=. just (val bh)
| otherwise = where_ $
t ^. WalletTxAccount ==. val ai &&.
t ^. WalletTxConfirmedHeight >=. just (val bh) &&.
t ^. WalletTxConfirmedHeight <. just (val $ bh + n)
getTx :: MonadIO m => TxHash -> SqlPersistT m (Maybe Tx)
getTx txid =
fmap (listToMaybe . map unValue) $ select $ from $ \t -> do
where_ $ t ^. WalletTxHash ==. val txid
limit 1
return $ t ^. WalletTxTx
getAccountTx :: MonadIO m
=> AccountId -> TxHash -> SqlPersistT m WalletTx
getAccountTx ai txid = do
res <- select $ from $ \t -> do
where_ ( t ^. WalletTxAccount ==. val ai
&&. t ^. WalletTxHash ==. val txid
)
return t
case res of
(Entity _ tx:_) -> return tx
_ -> liftIO . throwIO $ WalletException $ unwords
[ "Transaction does not exist:", cs $ txHashToHex txid ]
getPendingTxs :: MonadIO m => Int -> SqlPersistT m [TxHash]
getPendingTxs i =
fmap (map unValue) $ select $ from $ \t -> do
where_ $ t ^. WalletTxConfidence ==. val TxPending
when (i > 0) $ limit $ fromIntegral i
return $ t ^. WalletTxHash
importTx :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> Tx
-> Maybe (TBMChan Notif)
-> AccountId
-> SqlPersistT m ([WalletTx], [WalletAddr])
importTx tx notifChanM ai =
importTx' tx notifChanM ai =<< getInCoins tx (Just ai)
importTx' :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> Tx
-> Maybe (TBMChan Notif)
-> AccountId
-> [InCoinData]
-> SqlPersistT m ([WalletTx], [WalletAddr])
importTx' origTx notifChanM ai origInCoins = do
mergeResM <- mergeNoSigHashTxs ai origTx origInCoins
let tx = fromMaybe origTx mergeResM
origTxid = txHash origTx
txid = txHash tx
inCoins <- if origTxid == txid then return origInCoins else do
update $ \t -> do
set t [ WalletTxHash =. val txid
, WalletTxTx =. val tx
]
where_ ( t ^. WalletTxAccount ==. val ai
&&. t ^. WalletTxHash ==. val origTxid
)
update $ \t -> do
set t [ WalletCoinHash =. val txid ]
where_ ( t ^. WalletCoinAccount ==. val ai
&&. t ^. WalletCoinHash ==. val origTxid
)
let f (InCoinData c t x) = if walletTxHash t == origTxid
then InCoinData c
t{ walletTxHash = txid, walletTxTx = 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 notifChanM
else importOfflineTx tx notifChanM ai inCoins spendingTxs
where
toVerDat (InCoinData (Entity _ c) t _) =
(walletCoinScript c, OutPoint (walletTxHash t) (walletCoinPos c))
mergeNoSigHashTxs :: MonadIO m
=> AccountId
-> 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 walletTxConfidence prev of
TxOffline -> eitherToMaybe $
mergeTxs [tx, walletTxTx prev] outPoints
_ -> Nothing
_ -> Nothing
where
buildOutpoint c t = OutPoint (walletTxHash t) (walletCoinPos c)
f (InCoinData (Entity _ c) t _) = (walletCoinScript c, buildOutpoint c t)
outPoints = map f inCoins
importOfflineTx
:: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> Tx
-> Maybe (TBMChan Notif)
-> AccountId
-> [InCoinData]
-> [Entity WalletTx]
-> SqlPersistT m ([WalletTx], [WalletAddr])
importOfflineTx tx notifChanM ai inCoins spendingTxs = do
outCoins <- getNewCoins tx $ Just ai
when (null inCoins && null outCoins) err
prevM <- fmap (fmap entityVal) $ getBy $ UniqueAccTx ai txid
unless (canImport $ walletTxConfidence <$> prevM) err
killTxIds notifChanM $ map entityKey spendingTxs
txsRes <- buildAccTxs notifChanM tx TxOffline inCoins outCoins
newAddrs <- forM (nubBy sameKey $ map outCoinDataAddr outCoins) $
useAddress . entityVal
return (txsRes, concat newAddrs)
where
txid = txHash tx
canImport prevConfM =
(isNothing prevConfM || prevConfM == Just TxOffline) &&
canSpendCoins inCoins spendingTxs True
sameKey e1 e2 = entityKey e1 == entityKey e2
err = liftIO . throwIO $ WalletException
"Could not import offline transaction"
importNetTx
:: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> Tx
-> Maybe (TBMChan Notif)
-> SqlPersistT m ([WalletTx], [WalletAddr])
importNetTx tx notifChanM = do
inCoins <- getInCoins tx Nothing
outCoins <- getNewCoins tx Nothing
if null inCoins && null outCoins then return ([],[]) else do
updateNosigHash tx (nosigTxHash tx) txid
spendingTxs <- getSpendingTxs tx Nothing
let confidence | canSpendCoins inCoins spendingTxs False = TxPending
| otherwise = TxDead
when (confidence /= TxDead) $
killTxIds notifChanM $ map entityKey spendingTxs
txRes <- buildAccTxs notifChanM tx confidence inCoins outCoins
newAddrs <- forM (nubBy sameKey $ map outCoinDataAddr outCoins) $
useAddress . entityVal
forM_ notifChanM $ \notifChan -> forM_ txRes $
\tx' -> do
let ai = walletTxAccount tx'
Account{..} <-
fromMaybe (error "Velociraptors ate you") <$> get ai
liftIO $ atomically $ writeTBMChan notifChan $
NotifTx $ toJsonTx accountName Nothing tx'
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 ^. WalletTxNosigHash ==. val nosig
&&. t ^. WalletTxHash !=. val txid
)
return $ t ^. WalletTxHash
let toUpdate = map unValue res
unless (null toUpdate) $ do
splitUpdate toUpdate $ \hs t -> do
set t [ WalletTxHash =. val txid
, WalletTxTx =. val tx
]
where_ $ t ^. WalletTxHash `in_` valList hs
splitUpdate toUpdate $ \hs c -> do
set c [ WalletCoinHash =. val txid ]
where_ $ c ^. WalletCoinHash `in_` valList hs
canSpendCoins :: [InCoinData]
-> [Entity WalletTx]
-> Bool
-> Bool
canSpendCoins inCoins spendingTxs offline =
all validCoin inCoins &&
all validSpend spendingTxs
where
validCoin (InCoinData _ t _)
| offline = walletTxConfidence t /= TxDead
| otherwise = walletTxConfidence t `elem` [TxPending, TxBuilding]
validSpend = (== TxOffline) . walletTxConfidence . entityVal
getInCoins :: MonadIO m
=> Tx
-> Maybe AccountId
-> SqlPersistT m [InCoinData]
getInCoins tx aiM = do
res <- splitSelect ops $ \os -> from $ \(c `InnerJoin` t `InnerJoin` x) -> do
on $ x ^. WalletAddrId ==. c ^. WalletCoinAddr
on $ t ^. WalletTxId ==. c ^. WalletCoinTx
where_ $ case aiM of
Just ai ->
c ^. WalletCoinAccount ==. 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 ^. WalletCoinHash ==. val h &&.
c ^. WalletCoinPos ==. val i
getSpendingTxs :: MonadIO m
=> Tx
-> Maybe AccountId
-> SqlPersistT m [Entity WalletTx]
getSpendingTxs tx aiM
| null txInputs = return []
| otherwise =
splitSelect txInputs $ \ins -> from $ \(s `InnerJoin` t) -> do
on $ s ^. SpentCoinSpendingTx ==. t ^. WalletTxId
let cond = t ^. WalletTxHash !=. val txid
&&. limitSpent s ins
where_ $ case aiM of
Just ai -> cond &&. s ^. SpentCoinAccount ==. 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 ^. SpentCoinHash ==. val h &&.
s ^. SpentCoinPos ==. val i
getNewCoins :: MonadIO m
=> Tx
-> Maybe AccountId
-> SqlPersistT m [OutCoinData]
getNewCoins tx aiM = do
addrs <- splitSelect uniqueAddrs $ \as -> from $ \x -> do
let cond = x ^. WalletAddrAddress `in_` valList as
where_ $ case aiM of
Just ai -> cond &&. x ^. WalletAddrAccount ==. 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 == walletAddrAddress addr
in map (toCoin addrEnt) $ filter f outList
toCoin addrEnt (_, out, pos, so) = OutCoinData
{ outCoinDataAddr = addrEnt
, outCoinDataPos = pos
, outCoinDataValue = outValue out
, outCoinDataScript = so
}
getDataFromOutput :: TxOut -> Either String (Address, ScriptOutput)
getDataFromOutput out = do
so <- decodeOutputBS $ scriptOutput out
addr <- outputAddress so
return (addr, so)
isCoinbaseTx :: Tx -> Bool
isCoinbaseTx tx =
length (txIn tx) == 1 && outPointHash (prevOutput $ head (txIn tx)) ==
"0000000000000000000000000000000000000000000000000000000000000000"
spendInputs :: MonadIO m
=> AccountId
-> WalletTxId
-> Tx
-> SqlPersistT m ()
spendInputs ai ti tx = do
now <- liftIO getCurrentTime
splitInsertMany_ $ map (buildSpentCoin now) txInputs
where
txInputs = map prevOutput $ txIn tx
buildSpentCoin now (OutPoint h p) =
SpentCoin{ spentCoinAccount = ai
, spentCoinHash = h
, spentCoinPos = p
, spentCoinSpendingTx = ti
, spentCoinCreated = now
}
buildAccTxs :: MonadIO m
=> Maybe (TBMChan Notif)
-> Tx
-> TxConfidence
-> [InCoinData]
-> [OutCoinData]
-> SqlPersistT m [WalletTx]
buildAccTxs notifChanM tx confidence inCoins outCoins = do
now <- liftIO getCurrentTime
let grouped = groupCoinsByAccount inCoins outCoins
forM (M.toList grouped) $ \(ai, (is, os)) -> do
let atx = buildAccTx tx confidence ai is os now
Entity ti newAtx <- P.insertBy atx >>= \resE -> case resE of
Left (Entity ti prev) -> do
let prevConf = walletTxConfidence prev
newConf | confidence == TxDead = TxDead
| prevConf == TxBuilding = TxBuilding
| otherwise = confidence
let newAtx = atx
{ walletTxConfidence = newConf
, walletTxConfirmedBy = walletTxConfirmedBy prev
, walletTxConfirmedHeight = walletTxConfirmedHeight prev
, walletTxConfirmedDate = walletTxConfirmedDate prev
}
replace ti newAtx
when (newConf /= TxDead && prevConf == TxDead) $
spendInputs ai ti tx
when (prevConf /= TxDead && newConf == TxDead) $
killTxIds notifChanM [ti]
return (Entity ti newAtx)
Right ti -> do
when (confidence /= TxDead) $ spendInputs ai ti tx
return (Entity ti atx)
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 newAtx
where
toCoin ai accTxId now (OutCoinData addrEnt pos vl so) = WalletCoin
{ walletCoinAccount = ai
, walletCoinHash = txHash tx
, walletCoinPos = pos
, walletCoinTx = accTxId
, walletCoinValue = vl
, walletCoinScript = so
, walletCoinAddr = entityKey addrEnt
, walletCoinCreated = now
}
buildAccTx :: Tx
-> TxConfidence
-> AccountId
-> [InCoinData]
-> [OutCoinData]
-> UTCTime
-> WalletTx
buildAccTx tx confidence ai inCoins outCoins now = WalletTx
{ walletTxAccount = ai
, walletTxHash = txHash tx
, walletTxNosigHash = nosigTxHash tx
, walletTxType = txType
, walletTxInValue = inVal
, walletTxOutValue = outVal
, walletTxInputs =
let f h i (InCoinData (Entity _ c) t _) =
walletTxHash t == h && walletCoinPos c == i
toInfo (a, OutPoint h i) = case find (f h i) inCoins of
Just (InCoinData (Entity _ c) _ _) ->
AddressInfo a (Just $ walletCoinValue c) True
_ -> AddressInfo a Nothing False
in map toInfo allInAddrs
, walletTxOutputs =
let toInfo (a,i,v) = AddressInfo a (Just v) $ ours i
ours i = isJust $ find ((== i) . outCoinDataPos) outCoins
in map toInfo allOutAddrs \\ changeAddrs
, walletTxChange = changeAddrs
, walletTxTx = tx
, walletTxIsCoinbase = isCoinbaseTx tx
, walletTxConfidence = confidence
, walletTxConfirmedBy = Nothing
, walletTxConfirmedHeight = Nothing
, walletTxConfirmedDate = Nothing
, walletTxCreated = now
}
where
inVal = sum $ map outCoinDataValue outCoins
outVal = sum $ map coinValue inCoins
allMyCoins = length inCoins == length (txIn tx) &&
length outCoins == length (txOut tx)
txType
| allMyCoins = TxSelf
| inVal == outVal = TxSelf
| inVal > outVal = TxIncoming
| otherwise = TxOutgoing
allInAddrs =
let f inp = do
input <- decodeInputBS (scriptInput inp)
addr <- inputAddress input
return (addr, prevOutput inp)
in rights $ map f $ txIn tx
allOutAddrs =
let f op i = do
addr <- outputAddress =<< decodeOutputBS (scriptOutput op)
return (addr, i, outValue op)
in rights $ zipWith f (txOut tx) [0..]
changeAddrs
| txType == TxIncoming = []
| otherwise =
let isInternal = (== AddressInternal) . walletAddrType
. entityVal . outCoinDataAddr
f = walletAddrAddress . entityVal . outCoinDataAddr
toInfo c = AddressInfo (f c) (Just $ outCoinDataValue c) True
in map toInfo $ filter isInternal outCoins
groupCoinsByAccount
:: [InCoinData]
-> [OutCoinData]
-> M.Map AccountId ([InCoinData], [OutCoinData])
groupCoinsByAccount inCoins outCoins =
M.unionWith merge inMap outMap
where
f coin@(InCoinData _ t _) = (walletTxAccount t, [coin])
g coin = (walletAddrAccount $ 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
deleteTx :: (MonadIO m, MonadThrow m) => TxHash -> SqlPersistT m ()
deleteTx txid = do
ts <- select $ from $ \t -> do
where_ $ t ^. WalletTxHash ==. val txid
return t
case ts of
[] -> throwM $ WalletException $ unwords
[ "Cannot delete inexistent transaction"
, cs (txHashToHex txid)
]
Entity{entityVal = WalletTx{walletTxConfidence = TxBuilding}} : _ ->
throwM $ WalletException $ unwords
[ "Cannot delete confirmed transaction"
, cs (txHashToHex txid)
]
_ -> return ()
children <- fmap (map unValue) $ select $ from $
\(t `InnerJoin` c `InnerJoin` s `InnerJoin` t2) -> do
on $ s ^. SpentCoinSpendingTx ==. t2 ^. WalletTxId
on ( c ^. WalletCoinAccount ==. t ^. WalletTxAccount
&&. c ^. WalletCoinHash ==. s ^. SpentCoinHash
&&. c ^. WalletCoinPos ==. s ^. SpentCoinPos
)
on $ c ^. WalletCoinTx ==. t ^. WalletTxId
where_ $ t ^. WalletTxHash ==. val txid
return $ t2 ^. WalletTxHash
forM_ children deleteTx
forM_ ts $ \Entity{entityKey = ti} ->
delete $ from $ \s -> where_ $ s ^. SpentCoinSpendingTx ==. val ti
delete $ from $ \s -> where_ $ s ^. SpentCoinHash ==. val txid
forM_ ts $ \Entity{entityKey = ti} -> do
delete $ from $ \c -> where_ $ c ^. WalletCoinTx ==. val ti
delete $ from $ \t -> where_ $ t ^. WalletTxId ==. val ti
killTxIds :: MonadIO m
=> Maybe (TBMChan Notif)
-> [WalletTxId]
-> SqlPersistT m ()
killTxIds notifChanM txIds = do
children <- splitSelect txIds $ \ts -> from $ \(t `InnerJoin` s) -> do
on ( s ^. SpentCoinAccount ==. t ^. WalletTxAccount
&&. s ^. SpentCoinHash ==. t ^. WalletTxHash
)
where_ $ t ^. WalletTxId `in_` valList ts
return $ s ^. SpentCoinSpendingTx
splitUpdate txIds $ \ts t -> do
set t [ WalletTxConfidence =. val TxDead ]
where_ $ t ^. WalletTxId `in_` valList ts
case notifChanM of
Nothing -> return ()
Just notifChan -> do
ts' <- fmap (map entityVal) $
splitSelect txIds $ \ts -> from $ \t -> do
where_ $ t ^. WalletTxId `in_` valList ts
return t
forM_ ts' $ \tx -> do
let ai = walletTxAccount tx
Account{..} <-
fromMaybe (error "More velociraptors coming") <$> get ai
liftIO $ atomically $ writeTBMChan notifChan $
NotifTx $ toJsonTx accountName Nothing tx
splitDelete txIds $ \ts -> from $ \s ->
where_ $ s ^. SpentCoinSpendingTx `in_` valList ts
unless (null children) $ killTxIds notifChanM $ nub $ map unValue children
killTxs :: MonadIO m
=> Maybe (TBMChan Notif)
-> [TxHash]
-> SqlPersistT m ()
killTxs notifChanM txHashes = do
res <- splitSelect txHashes $ \hs -> from $ \t -> do
where_ $ t ^. WalletTxHash `in_` valList hs
return $ t ^. WalletTxId
killTxIds notifChanM $ map unValue res
importMerkles :: MonadIO m
=> BlockChainAction
-> [MerkleTxs]
-> Maybe (TBMChan Notif)
-> SqlPersistT m ()
importMerkles action expTxsLs notifChanM =
when (isBestChain action || isChainReorg action) $ do
case action of
ChainReorg _ os _ ->
let hs = map (Just . nodeHash) os
in splitUpdate hs $ \h t -> do
set t [ WalletTxConfidence =. val TxPending
, WalletTxConfirmedBy =. val Nothing
, WalletTxConfirmedHeight =. val Nothing
, WalletTxConfirmedDate =. val Nothing
]
where_ $ t ^. WalletTxConfirmedBy `in_` valList h
_ -> return ()
deadTxs <- splitSelect (concat expTxsLs) $ \ts -> from $ \t -> do
where_ ( t ^. WalletTxHash `in_` valList ts
&&. t ^. WalletTxConfidence ==. val TxDead
)
return $ t ^. WalletTxTx
forM_ deadTxs $ reviveTx notifChanM . unValue
forM_ (zip (actionNodes action) expTxsLs) $ \(node, hs) -> do
let hash = nodeHash node
height = nodeBlockHeight node
splitUpdate hs $ \h t -> do
set t [ WalletTxConfidence =. val TxBuilding
, WalletTxConfirmedBy =. val (Just hash)
, WalletTxConfirmedHeight =.
val (Just height)
, WalletTxConfirmedDate =.
val (Just $ nodeTimestamp node)
]
where_ $ t ^. WalletTxHash `in_` valList h
ts <- fmap (map entityVal) $ splitSelect hs $ \h -> from $ \t -> do
where_ $ t ^. WalletTxHash `in_` valList h
return t
setBestBlock hash height
forM_ notifChanM $ \notifChan -> do
liftIO $ atomically $ writeTBMChan notifChan $
NotifBlock JsonBlock
{ jsonBlockHash = hash
, jsonBlockHeight = height
, jsonBlockPrev = nodePrev node
}
sendTxs notifChan ts hash height
where
sendTxs notifChan ts hash height = forM_ ts $ \tx -> do
let ai = walletTxAccount tx
Account{..} <- fromMaybe (error "Dino crisis") <$> get ai
liftIO $ atomically $ writeTBMChan notifChan $
NotifTx $ toJsonTx accountName (Just (hash, height)) tx
setBestBlock :: MonadIO m => BlockHash -> Word32 -> SqlPersistT m ()
setBestBlock bid i = update $ \t -> set t [ WalletStateBlock =. val bid
, WalletStateHeight =. val i
]
walletBestBlock :: MonadIO m => SqlPersistT m (BlockHash, Word32)
walletBestBlock = do
cfgM <- fmap entityVal <$> P.selectFirst [] []
return $ case cfgM of
Just WalletState{..} -> (walletStateBlock, walletStateHeight)
Nothing -> throw $ WalletException $ unwords
[ "Could not get the best block."
, "Wallet database is probably not initialized"
]
reviveTx :: MonadIO m
=> Maybe (TBMChan Notif)
-> Tx
-> SqlPersistT m ()
reviveTx notifChanM tx = do
spendingTxs <- getSpendingTxs tx Nothing
killTxIds notifChanM $ map entityKey spendingTxs
ids <- select $ from $ \t -> do
where_ $ t ^. WalletTxHash ==. val (txHash tx)
&&. t ^. WalletTxConfidence ==. val TxDead
return (t ^. WalletTxAccount, t ^. WalletTxId)
forM_ ids $ \(Value ai, Value ti) -> spendInputs ai ti tx
let ids' = map (unValue . snd) ids
splitUpdate ids' $ \is t -> do
set t [ WalletTxConfidence =. val TxPending
, WalletTxConfirmedBy =. val Nothing
, WalletTxConfirmedHeight =. val Nothing
, WalletTxConfirmedDate =. val Nothing
]
where_ $ t ^. WalletTxId `in_` valList is
case notifChanM of
Nothing -> return ()
Just notifChan -> do
ts' <- fmap (map entityVal) $
splitSelect ids' $ \ts -> from $ \t -> do
where_ $ t ^. WalletTxId `in_` valList ts
return t
forM_ ts' $ \tx' -> do
let ai = walletTxAccount tx'
Account{..} <-
fromMaybe (error "Tyranossaurus Rex attacks") <$> get ai
liftIO $ atomically $ writeTBMChan notifChan $
NotifTx $ toJsonTx accountName Nothing tx'
createWalletTx
:: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> Entity Account
-> Maybe (TBMChan Notif)
-> Maybe XPrvKey
-> [(Address,Word64)]
-> Word64
-> Word32
-> Bool
-> Bool
-> SqlPersistT m (WalletTx, [WalletAddr])
createWalletTx accE@(Entity ai acc) notifM masterM dests fee minConf rcptFee sign = do
(unsignedTx, inCoins, newChangeAddrs) <-
buildUnsignedTx accE dests fee minConf rcptFee
let dat = map toCoinSignData inCoins
tx | sign = signOfflineTx acc masterM unsignedTx dat
| otherwise = unsignedTx
(res, newAddrs) <- importTx' tx notifM ai inCoins
case res of
(txRes:_) -> return (txRes, newAddrs ++ newChangeAddrs)
_ -> liftIO . throwIO $ WalletException
"Error while importing the new transaction"
toCoinSignData :: InCoinData -> CoinSignData
toCoinSignData (InCoinData (Entity _ c) t x) =
CoinSignData (OutPoint (walletTxHash t) (walletCoinPos c))
(walletCoinScript c)
deriv
where
deriv = Deriv :/ addrTypeIndex (walletAddrType x) :/ walletAddrIndex x
buildUnsignedTx
:: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> Entity Account
-> [(Address, Word64)]
-> Word64
-> Word32
-> Bool
-> SqlPersistT m (Tx, [InCoinData], [WalletAddr])
buildUnsignedTx _ [] _ _ _ = liftIO . throwIO $ WalletException
"buildUnsignedTx: No transaction recipients have been provided"
buildUnsignedTx accE@(Entity ai acc) origDests origFee minConf rcptFee = do
let p = case accountType acc of
AccountMultisig m n -> (m, n)
_ -> throw . WalletException $ "Invalid account type"
fee = if rcptFee then 0 else origFee
coins | isMultisigAccount acc = chooseMSCoins tot fee p True
| otherwise = chooseCoins tot fee True
orderPolicy c _ = [desc $ c ^. WalletCoinValue]
selectRes <- spendableCoins ai minConf orderPolicy
let (selected, change) = either (throw . WalletException) id $ coins selectRes
totFee | isMultisigAccount acc = getMSFee origFee p (length selected)
| otherwise = getFee origFee (length selected)
value = snd $ head origDests
when (rcptFee && value < totFee + 5430) $ throw $ WalletException
"First recipient cannot cover transaction fees"
let dests | rcptFee =
second (const $ value - totFee) (head origDests) :
tail origDests
| otherwise = origDests
when (snd (head dests) <= 0) $ throw $
WalletException "Transaction fees too high"
(allDests, addrs) <- if change < 5430
then return (dests, [])
else do
(addr, chng) <- newChangeAddr change
return ((walletAddrAddress addr, chng) : dests, [addr])
case buildAddrTx (map toOutPoint selected) $ map toBase58 allDests of
Right tx -> return (tx, selected, addrs)
Left err -> liftIO . throwIO $ WalletException err
where
tot = sum $ map snd origDests
toBase58 (a, v) = (addrToBase58 a, v)
toOutPoint (InCoinData (Entity _ c) t _) =
OutPoint (walletTxHash t) (walletCoinPos c)
newChangeAddr change = do
let lq = ListRequest 0 0 False
(as, _) <- unusedAddresses accE AddressInternal lq
case as of
(a:_) -> do
_ <- useAddress a
return (a, change)
_ -> liftIO . throwIO $ WalletException
"No unused addresses available"
signAccountTx :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> Entity Account
-> Maybe (TBMChan Notif)
-> Maybe XPrvKey
-> TxHash
-> SqlPersistT m ([WalletTx], [WalletAddr])
signAccountTx (Entity ai acc) notifChanM masterM txid = do
(OfflineTxData tx dat, inCoins) <- getOfflineTxData ai txid
let signedTx = signOfflineTx acc masterM tx dat
importTx' signedTx notifChanM ai inCoins
getOfflineTxData
:: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> AccountId
-> TxHash
-> SqlPersistT m (OfflineTxData, [InCoinData])
getOfflineTxData ai txid = do
txM <- getBy $ UniqueAccTx ai txid
case txM of
Just (Entity _ tx) -> do
unless (walletTxConfidence tx == TxOffline) $ liftIO . throwIO $
WalletException "Can only sign offline transactions."
inCoins <- getInCoins (walletTxTx tx) $ Just ai
return
( OfflineTxData (walletTxTx tx) $ map toCoinSignData inCoins
, inCoins
)
_ -> liftIO . throwIO $ WalletException $ unwords
[ "Invalid txid", cs $ txHashToHex txid ]
signOfflineTx :: Account
-> Maybe XPrvKey
-> Tx
-> [CoinSignData]
-> Tx
signOfflineTx acc masterM tx coinSignData
| not validMaster = throw $ WalletException
"Master key not valid"
| otherwise = either (throw . WalletException) id $
signTx tx sigData $ map (toPrvKeyG . xPrvKey) prvKeys
where
sigData = map (toSigData acc) coinSignData
prvKeys = map toPrvKey coinSignData
toSigData acc' (CoinSignData op so deriv) =
SigInput so op (SigAll False) $
if isMultisigAccount acc
then Just $ getPathRedeem acc' deriv
else Nothing
toPrvKey (CoinSignData _ _ deriv) = derivePath deriv master
master = case masterM of
Just m -> case accountDerivation acc of
Just d -> derivePath d m
Nothing -> m
Nothing -> fromMaybe
(throw $ WalletException "No extended private key available")
(accountMaster acc)
validMaster = deriveXPubKey master `elem` accountKeys acc
spendableCoins
:: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> AccountId
-> Word32
-> ( SqlExpr (Entity WalletCoin)
-> SqlExpr (Entity WalletTx)
-> [SqlExpr OrderBy]
)
-> SqlPersistT m [InCoinData]
spendableCoins ai minConf orderPolicy =
fmap (map f) $ select $ spendableCoinsFrom ai minConf orderPolicy
where
f (c, t, x) = InCoinData c (entityVal t) (entityVal x)
spendableCoinsFrom
:: AccountId
-> Word32
-> ( SqlExpr (Entity WalletCoin)
-> SqlExpr (Entity WalletTx)
-> [SqlExpr OrderBy]
)
-> SqlQuery ( SqlExpr (Entity WalletCoin)
, SqlExpr (Entity WalletTx)
, SqlExpr (Entity WalletAddr)
)
spendableCoinsFrom ai minConf orderPolicy =
from $ \(c `InnerJoin` t `InnerJoin` x `LeftOuterJoin` s) -> do
on ( s ?. SpentCoinAccount ==. just (c ^. WalletCoinAccount)
&&. s ?. SpentCoinHash ==. just (c ^. WalletCoinHash)
&&. s ?. SpentCoinPos ==. just (c ^. WalletCoinPos)
)
on $ x ^. WalletAddrId ==. c ^. WalletCoinAddr
on $ t ^. WalletTxId ==. c ^. WalletCoinTx
where_ ( c ^. WalletCoinAccount ==. val ai
&&. t ^. WalletTxConfidence
`in_` valList [ TxPending, TxBuilding ]
&&. E.isNothing (s ?. SpentCoinId)
&&. limitConfirmations (Right t) minConf
)
orderBy (orderPolicy c t)
return (c, t, x)
limitConfirmations :: Either (SqlExpr (Maybe (Entity WalletTx)))
(SqlExpr (Entity WalletTx))
-> 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 ?. WalletTxConfirmedHeight
<=. just (just (selectHeight -. val (i - 1)))
Right t -> t ^. WalletTxConfirmedHeight
<=. just (selectHeight -. val (i - 1))
limitCoinbase = case txE of
Left t ->
not_ (coalesceDefault [t ?. WalletTxIsCoinbase] (val False)) ||.
limitConfs 100
Right t ->
not_ (t ^. WalletTxIsCoinbase) ||. limitConfs 100
selectHeight :: SqlExpr (Value Word32)
selectHeight = sub_select $ from $ \co -> do
limit 1
return $ co ^. WalletStateHeight
accountBalance :: MonadIO m
=> AccountId
-> Word32
-> Bool
-> SqlPersistT m Word64
accountBalance ai minconf offline = do
res <- select $ from $ \(c `InnerJoin`
t `LeftOuterJoin` s `LeftOuterJoin` st) -> do
on $ st ?. WalletTxId ==. s ?. SpentCoinSpendingTx
on ( s ?. SpentCoinAccount ==. just (c ^. WalletCoinAccount)
&&. s ?. SpentCoinHash ==. just (c ^. WalletCoinHash)
&&. s ?. SpentCoinPos ==. just (c ^. WalletCoinPos)
)
on $ t ^. WalletTxId ==. c ^. WalletCoinTx
let unspent = E.isNothing ( s ?. SpentCoinId )
spentOffline = st ?. WalletTxConfidence ==. just (val TxOffline)
cond = c ^. WalletCoinAccount ==. val ai
&&. t ^. WalletTxConfidence `in_` valList validConfidence
&&. if offline then unspent else unspent ||. spentOffline
where_ $ if minconf == 0
then cond
else cond &&. limitConfirmations (Right t) minconf
return $ sum_ (c ^. WalletCoinValue)
case res of
(Value (Just s):_) -> return $ floor (s :: Double)
_ -> return 0
where
validConfidence = TxPending : TxBuilding : [ TxOffline | offline ]
addressBalances :: MonadIO m
=> Entity Account
-> KeyIndex
-> KeyIndex
-> AddressType
-> Word32
-> Bool
-> SqlPersistT m [(KeyIndex, BalanceInfo)]
addressBalances accE@(Entity ai _) iMin iMax addrType minconf offline = do
res <- select $ from $ \(x `LeftOuterJoin` c `LeftOuterJoin`
t `LeftOuterJoin` s `LeftOuterJoin` st) -> do
let joinCond = st ?. WalletTxId ==. s ?. SpentCoinSpendingTx
on $ if offline
then joinCond
else joinCond &&.
st ?. WalletTxConfidence !=. just (val TxOffline)
on $ s ?. SpentCoinAccount ==. c ?. WalletCoinAccount
&&. s ?. SpentCoinHash ==. c ?. WalletCoinHash
&&. s ?. SpentCoinPos ==. c ?. WalletCoinPos
let txJoin = t ?. WalletTxId ==. c ?. WalletCoinTx
&&. t ?. WalletTxConfidence `in_` valList validConfidence
on $ if minconf == 0
then txJoin
else txJoin &&. limitConfirmations (Left t) minconf
on $ c ?. WalletCoinAddr ==. just (x ^. WalletAddrId)
let limitIndex
| iMin == iMax = x ^. WalletAddrIndex ==. val iMin
| otherwise = x ^. WalletAddrIndex >=. val iMin
&&. x ^. WalletAddrIndex <=. val iMax
where_ ( x ^. WalletAddrAccount ==. val ai
&&. limitIndex
&&. x ^. WalletAddrIndex <. subSelectAddrCount accE addrType
&&. x ^. WalletAddrType ==. val addrType
)
groupBy $ x ^. WalletAddrIndex
let unspent = E.isNothing $ st ?. WalletTxId
invalidTx = E.isNothing $ t ?. WalletTxId
return ( x ^. WalletAddrIndex
, sum_ $ case_
[ when_ invalidTx
then_ (val (Just 0))
] (else_ $ c ?. WalletCoinValue)
, sum_ $ case_
[ when_ (unspent ||. invalidTx)
then_ (val (Just 0))
] (else_ $ c ?. WalletCoinValue)
, count $ t ?. WalletTxId
, count $ case_
[ when_ invalidTx
then_ (val Nothing)
] (else_ $ st ?. WalletTxId)
)
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)
resetRescan :: MonadIO m => SqlPersistT m ()
resetRescan = do
P.deleteWhere ([] :: [P.Filter WalletCoin])
P.deleteWhere ([] :: [P.Filter SpentCoin])
P.deleteWhere ([] :: [P.Filter WalletTx])
setBestBlock (headerHash genesisHeader) 0