1636 lines
50 KiB
Haskell
1636 lines
50 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE EmptyDataDecls #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
{-# LANGUAGE DeriveAnyClass #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
|
|
module Zenith.DB where
|
|
|
|
import Control.Exception (throwIO)
|
|
import Control.Monad (forM_, when)
|
|
import Control.Monad.IO.Class (MonadIO, liftIO)
|
|
import Control.Monad.Logger (NoLoggingT, runNoLoggingT)
|
|
import Data.Bifunctor (bimap)
|
|
import qualified Data.ByteString as BS
|
|
import Data.HexString
|
|
import Data.List (group, sort)
|
|
import Data.Maybe (catMaybes, fromJust, isJust)
|
|
import Data.Pool (Pool)
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Encoding as TE
|
|
import Data.Word
|
|
import Database.Esqueleto.Experimental
|
|
import qualified Database.Persist as P
|
|
import qualified Database.Persist.Sqlite as PS
|
|
import Database.Persist.TH
|
|
import Haskoin.Transaction.Common
|
|
( OutPoint(..)
|
|
, TxIn(..)
|
|
, TxOut(..)
|
|
, txHashToHex
|
|
)
|
|
import qualified Lens.Micro as ML ((&), (.~), (^.))
|
|
import ZcashHaskell.Orchard (isValidUnifiedAddress)
|
|
import ZcashHaskell.Sapling (decodeSaplingOutputEsk)
|
|
import ZcashHaskell.Types
|
|
( DecodedNote(..)
|
|
, OrchardAction(..)
|
|
, OrchardBundle(..)
|
|
, OrchardSpendingKey(..)
|
|
, OrchardWitness(..)
|
|
, SaplingBundle(..)
|
|
, SaplingCommitmentTree(..)
|
|
, SaplingSpendingKey(..)
|
|
, SaplingWitness(..)
|
|
, Scope(..)
|
|
, ShieldedOutput(..)
|
|
, ShieldedSpend(..)
|
|
, ToBytes(..)
|
|
, Transaction(..)
|
|
, TransparentAddress(..)
|
|
, TransparentBundle(..)
|
|
, TransparentReceiver(..)
|
|
, UnifiedAddress(..)
|
|
, ZcashNet
|
|
, decodeHexText
|
|
)
|
|
import Zenith.Types
|
|
( Config(..)
|
|
, HexStringDB(..)
|
|
, OrchardSpendingKeyDB(..)
|
|
, PhraseDB(..)
|
|
, RseedDB(..)
|
|
, SaplingSpendingKeyDB(..)
|
|
, ScopeDB(..)
|
|
, TransparentSpendingKeyDB
|
|
, UnifiedAddressDB(..)
|
|
, ZcashNetDB(..)
|
|
, ZcashPool(..)
|
|
)
|
|
|
|
share
|
|
[mkPersist sqlSettings, mkMigrate "migrateAll"]
|
|
[persistLowerCase|
|
|
ZcashWallet
|
|
name T.Text
|
|
network ZcashNetDB
|
|
seedPhrase PhraseDB
|
|
birthdayHeight Int
|
|
lastSync Int default=0
|
|
UniqueWallet name network
|
|
deriving Show Eq
|
|
ZcashAccount
|
|
index Int
|
|
walletId ZcashWalletId
|
|
name T.Text
|
|
orchSpendKey OrchardSpendingKeyDB
|
|
sapSpendKey SaplingSpendingKeyDB
|
|
tPrivateKey TransparentSpendingKeyDB
|
|
UniqueAccount index walletId
|
|
UniqueAccName walletId name
|
|
deriving Show Eq
|
|
WalletAddress
|
|
index Int
|
|
accId ZcashAccountId
|
|
name T.Text
|
|
uAddress UnifiedAddressDB
|
|
scope ScopeDB
|
|
UniqueAddress index scope accId
|
|
UniqueAddName accId name
|
|
deriving Show Eq
|
|
WalletTransaction
|
|
txId HexStringDB
|
|
accId ZcashAccountId
|
|
block Int
|
|
conf Int
|
|
time Int
|
|
UniqueWTx txId accId
|
|
deriving Show Eq
|
|
UserTx
|
|
hex HexStringDB
|
|
address WalletAddressId OnDeleteCascade OnUpdateCascade
|
|
time Int
|
|
amount Int
|
|
memo T.Text
|
|
UniqueUTx hex address
|
|
deriving Show Eq
|
|
WalletTrNote
|
|
tx WalletTransactionId OnDeleteCascade OnUpdateCascade
|
|
accId ZcashAccountId OnDeleteCascade OnUpdateCascade
|
|
address WalletAddressId OnDeleteCascade OnUpdateCascade
|
|
value Word64
|
|
spent Bool
|
|
script BS.ByteString
|
|
change Bool
|
|
position Word64
|
|
UniqueTNote tx script
|
|
deriving Show Eq
|
|
WalletTrSpend
|
|
tx WalletTransactionId OnDeleteCascade OnUpdateCascade
|
|
note WalletTrNoteId OnDeleteCascade OnUpdateCascade
|
|
accId ZcashAccountId OnDeleteCascade OnUpdateCascade
|
|
value Word64
|
|
UniqueTrSpend tx accId
|
|
deriving Show Eq
|
|
WalletSapNote
|
|
tx WalletTransactionId OnDeleteCascade OnUpdateCascade
|
|
accId ZcashAccountId OnDeleteCascade OnUpdateCascade
|
|
value Word64
|
|
recipient BS.ByteString
|
|
memo T.Text
|
|
spent Bool
|
|
nullifier HexStringDB
|
|
position Word64
|
|
witness HexStringDB
|
|
change Bool
|
|
witPos ShieldOutputId OnDeleteIgnore OnUpdateIgnore
|
|
rseed RseedDB
|
|
UniqueSapNote tx nullifier
|
|
deriving Show Eq
|
|
WalletSapSpend
|
|
tx WalletTransactionId OnDeleteCascade OnUpdateCascade
|
|
note WalletSapNoteId OnDeleteCascade OnUpdateCascade
|
|
accId ZcashAccountId OnDeleteCascade OnUpdateCascade
|
|
value Word64
|
|
UniqueSapSepnd tx accId
|
|
deriving Show Eq
|
|
WalletOrchNote
|
|
tx WalletTransactionId OnDeleteCascade OnUpdateCascade
|
|
accId ZcashAccountId OnDeleteCascade OnUpdateCascade
|
|
value Word64
|
|
recipient BS.ByteString
|
|
memo T.Text
|
|
spent Bool
|
|
nullifier HexStringDB
|
|
position Word64
|
|
witness HexStringDB
|
|
change Bool
|
|
witPos OrchActionId OnDeleteIgnore OnUpdateIgnore
|
|
rho BS.ByteString
|
|
rseed RseedDB
|
|
UniqueOrchNote tx nullifier
|
|
deriving Show Eq
|
|
WalletOrchSpend
|
|
tx WalletTransactionId OnDeleteCascade OnUpdateCascade
|
|
note WalletOrchNoteId OnDeleteCascade OnUpdateCascade
|
|
accId ZcashAccountId OnDeleteCascade OnUpdateCascade
|
|
value Word64
|
|
UniqueOrchSpend tx accId
|
|
deriving Show Eq
|
|
ZcashTransaction
|
|
block Int
|
|
txId HexStringDB
|
|
conf Int
|
|
time Int
|
|
UniqueTx block txId
|
|
deriving Show Eq
|
|
TransparentNote
|
|
tx ZcashTransactionId
|
|
value Word64
|
|
script BS.ByteString
|
|
position Int
|
|
UniqueTNPos tx position
|
|
deriving Show Eq
|
|
TransparentSpend
|
|
tx ZcashTransactionId
|
|
outPointHash HexStringDB
|
|
outPointIndex Word64
|
|
script BS.ByteString
|
|
seq Word64
|
|
position Int
|
|
UniqueTSPos tx position
|
|
deriving Show Eq
|
|
OrchAction
|
|
tx ZcashTransactionId
|
|
nf HexStringDB
|
|
rk HexStringDB
|
|
cmx HexStringDB
|
|
ephKey HexStringDB
|
|
encCipher HexStringDB
|
|
outCipher HexStringDB
|
|
cv HexStringDB
|
|
auth HexStringDB
|
|
position Int
|
|
UniqueOAPos tx position
|
|
deriving Show Eq
|
|
ShieldOutput
|
|
tx ZcashTransactionId
|
|
cv HexStringDB
|
|
cmu HexStringDB
|
|
ephKey HexStringDB
|
|
encCipher HexStringDB
|
|
outCipher HexStringDB
|
|
proof HexStringDB
|
|
position Int
|
|
UniqueSOPos tx position
|
|
deriving Show Eq
|
|
ShieldSpend
|
|
tx ZcashTransactionId
|
|
cv HexStringDB
|
|
anchor HexStringDB
|
|
nullifier HexStringDB
|
|
rk HexStringDB
|
|
proof HexStringDB
|
|
authSig HexStringDB
|
|
position Int
|
|
UniqueSSPos tx position
|
|
deriving Show Eq
|
|
QrCode
|
|
address WalletAddressId OnDeleteCascade OnUpdateCascade
|
|
version ZcashPool
|
|
bytes BS.ByteString
|
|
height Int
|
|
width Int
|
|
name T.Text
|
|
UniqueQr address version
|
|
deriving Show Eq
|
|
|]
|
|
|
|
-- * Database functions
|
|
-- | Initializes the database
|
|
initDb ::
|
|
T.Text -- ^ The database path to check
|
|
-> IO ()
|
|
initDb dbName = do
|
|
PS.runSqlite dbName $ do runMigration migrateAll
|
|
|
|
initPool :: T.Text -> NoLoggingT IO ConnectionPool
|
|
initPool dbPath = do
|
|
let dbInfo = PS.mkSqliteConnectionInfo dbPath
|
|
PS.createSqlitePoolFromInfo dbInfo 5
|
|
|
|
-- | Upgrade the database
|
|
upgradeDb ::
|
|
T.Text -- ^ database path
|
|
-> IO ()
|
|
upgradeDb dbName = do
|
|
PS.runSqlite dbName $ do runMigrationUnsafe migrateAll
|
|
|
|
-- | Get existing wallets from database
|
|
getWallets :: ConnectionPool -> ZcashNet -> IO [Entity ZcashWallet]
|
|
getWallets pool n =
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
wallets <- from $ table @ZcashWallet
|
|
where_ (wallets ^. ZcashWalletNetwork ==. val (ZcashNetDB n))
|
|
pure wallets
|
|
|
|
-- | Save a new wallet to the database
|
|
saveWallet ::
|
|
ConnectionPool -- ^ The database path to use
|
|
-> ZcashWallet -- ^ The wallet to add to the database
|
|
-> IO (Maybe (Entity ZcashWallet))
|
|
saveWallet pool w =
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUniqueEntity w
|
|
|
|
-- | Update the last sync block for the wallet
|
|
updateWalletSync :: ConnectionPool -> Int -> ZcashWalletId -> IO ()
|
|
updateWalletSync pool b i = do
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
update $ \w -> do
|
|
set w [ZcashWalletLastSync =. val b]
|
|
where_ $ w ^. ZcashWalletId ==. val i
|
|
|
|
-- | Returns a list of accounts associated with the given wallet
|
|
getAccounts ::
|
|
ConnectionPool -- ^ The database path
|
|
-> ZcashWalletId -- ^ The wallet ID to check
|
|
-> NoLoggingT IO [Entity ZcashAccount]
|
|
getAccounts pool w =
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
accs <- from $ table @ZcashAccount
|
|
where_ (accs ^. ZcashAccountWalletId ==. val w)
|
|
pure accs
|
|
|
|
getAccountById ::
|
|
ConnectionPool -> ZcashAccountId -> IO (Maybe (Entity ZcashAccount))
|
|
getAccountById pool za = do
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
selectOne $ do
|
|
accs <- from $ table @ZcashAccount
|
|
where_ (accs ^. ZcashAccountId ==. val za)
|
|
pure accs
|
|
|
|
-- | Returns the largest account index for the given wallet
|
|
getMaxAccount ::
|
|
ConnectionPool -- ^ The database path
|
|
-> ZcashWalletId -- ^ The wallet ID to check
|
|
-> IO Int
|
|
getMaxAccount pool w = do
|
|
a <-
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
selectOne $ do
|
|
accs <- from $ table @ZcashAccount
|
|
where_ (accs ^. ZcashAccountWalletId ==. val w)
|
|
orderBy [desc $ accs ^. ZcashAccountIndex]
|
|
pure accs
|
|
case a of
|
|
Nothing -> return $ -1
|
|
Just x -> return $ zcashAccountIndex $ entityVal x
|
|
|
|
-- | Save a new account to the database
|
|
saveAccount ::
|
|
ConnectionPool -- ^ The database path
|
|
-> ZcashAccount -- ^ The account to add to the database
|
|
-> IO (Maybe (Entity ZcashAccount))
|
|
saveAccount pool a =
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUniqueEntity a
|
|
|
|
-- | Returns the largest block in storage
|
|
getMaxBlock ::
|
|
Pool SqlBackend -- ^ The database pool
|
|
-> NoLoggingT IO Int
|
|
getMaxBlock pool = do
|
|
b <-
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
selectOne $ do
|
|
txs <- from $ table @ZcashTransaction
|
|
where_ (txs ^. ZcashTransactionBlock >. val 0)
|
|
orderBy [desc $ txs ^. ZcashTransactionBlock]
|
|
pure txs
|
|
case b of
|
|
Nothing -> return $ -1
|
|
Just x -> return $ zcashTransactionBlock $ entityVal x
|
|
|
|
-- | Returns a list of addresses associated with the given account
|
|
getAddresses ::
|
|
ConnectionPool -- ^ The database path
|
|
-> ZcashAccountId -- ^ The account ID to check
|
|
-> NoLoggingT IO [Entity WalletAddress]
|
|
getAddresses pool a =
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
addrs <- from $ table @WalletAddress
|
|
where_ (addrs ^. WalletAddressAccId ==. val a)
|
|
where_ (addrs ^. WalletAddressScope ==. val (ScopeDB External))
|
|
pure addrs
|
|
|
|
getAddressById ::
|
|
ConnectionPool -> WalletAddressId -> IO (Maybe (Entity WalletAddress))
|
|
getAddressById pool a = do
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
selectOne $ do
|
|
addr <- from $ table @WalletAddress
|
|
where_ (addr ^. WalletAddressId ==. val a)
|
|
pure addr
|
|
|
|
-- | Returns a list of change addresses associated with the given account
|
|
getInternalAddresses ::
|
|
ConnectionPool -- ^ The database path
|
|
-> ZcashAccountId -- ^ The account ID to check
|
|
-> NoLoggingT IO [Entity WalletAddress]
|
|
getInternalAddresses pool a =
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
addrs <- from $ table @WalletAddress
|
|
where_ (addrs ^. WalletAddressAccId ==. val a)
|
|
where_ (addrs ^. WalletAddressScope ==. val (ScopeDB Internal))
|
|
pure addrs
|
|
|
|
-- | Returns a list of addressess associated with the given wallet
|
|
getWalletAddresses ::
|
|
ConnectionPool -- ^ The database path
|
|
-> ZcashWalletId -- ^ the wallet to search
|
|
-> NoLoggingT IO [Entity WalletAddress]
|
|
getWalletAddresses pool w = do
|
|
accs <- getAccounts pool w
|
|
addrs <- mapM (getAddresses pool . entityKey) accs
|
|
return $ concat addrs
|
|
|
|
getExternalAddresses :: ConnectionPool -> IO [Entity WalletAddress]
|
|
getExternalAddresses pool = do
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
addrs <- from $ table @WalletAddress
|
|
where_ $ addrs ^. WalletAddressScope ==. val (ScopeDB External)
|
|
return addrs
|
|
|
|
-- | Returns the largest address index for the given account
|
|
getMaxAddress ::
|
|
ConnectionPool -- ^ The database path
|
|
-> ZcashAccountId -- ^ The account ID to check
|
|
-> Scope -- ^ The scope of the address
|
|
-> IO Int
|
|
getMaxAddress pool aw s = do
|
|
a <-
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
selectOne $ do
|
|
addrs <- from $ table @WalletAddress
|
|
where_ $ addrs ^. WalletAddressAccId ==. val aw
|
|
where_ $ addrs ^. WalletAddressScope ==. val (ScopeDB s)
|
|
orderBy [desc $ addrs ^. WalletAddressIndex]
|
|
pure addrs
|
|
case a of
|
|
Nothing -> return $ -1
|
|
Just x -> return $ walletAddressIndex $ entityVal x
|
|
|
|
-- | Save a new address to the database
|
|
saveAddress ::
|
|
ConnectionPool -- ^ the database path
|
|
-> WalletAddress -- ^ The wallet to add to the database
|
|
-> IO (Maybe (Entity WalletAddress))
|
|
saveAddress pool w =
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUniqueEntity w
|
|
|
|
-- | Save a transaction to the data model
|
|
saveTransaction ::
|
|
ConnectionPool -- ^ the database path
|
|
-> Int -- ^ block time
|
|
-> Transaction -- ^ The transaction to save
|
|
-> NoLoggingT IO (Key ZcashTransaction)
|
|
saveTransaction pool t wt =
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
let ix = [0 ..]
|
|
w <-
|
|
insert $
|
|
ZcashTransaction (tx_height wt) (HexStringDB $ tx_id wt) (tx_conf wt) t
|
|
when (isJust $ tx_transpBundle wt) $ do
|
|
_ <-
|
|
insertMany_ $
|
|
zipWith (curry (storeTxOut w)) ix $
|
|
(tb_vout . fromJust . tx_transpBundle) wt
|
|
_ <-
|
|
insertMany_ $
|
|
zipWith (curry (storeTxIn w)) ix $
|
|
(tb_vin . fromJust . tx_transpBundle) wt
|
|
return ()
|
|
when (isJust $ tx_saplingBundle wt) $ do
|
|
_ <-
|
|
insertMany_ $
|
|
zipWith (curry (storeSapSpend w)) ix $
|
|
(sbSpends . fromJust . tx_saplingBundle) wt
|
|
_ <-
|
|
insertMany_ $
|
|
zipWith (curry (storeSapOutput w)) ix $
|
|
(sbOutputs . fromJust . tx_saplingBundle) wt
|
|
return ()
|
|
when (isJust $ tx_orchardBundle wt) $
|
|
insertMany_ $
|
|
zipWith (curry (storeOrchAction w)) ix $
|
|
(obActions . fromJust . tx_orchardBundle) wt
|
|
return w
|
|
where
|
|
storeTxOut :: ZcashTransactionId -> (Int, TxOut) -> TransparentNote
|
|
storeTxOut wid (i, TxOut v s) = TransparentNote wid (fromIntegral v) s i
|
|
storeTxIn :: ZcashTransactionId -> (Int, TxIn) -> TransparentSpend
|
|
storeTxIn wid (i, TxIn (OutPoint h k) s sq) =
|
|
TransparentSpend
|
|
wid
|
|
(HexStringDB . fromText $ txHashToHex h)
|
|
(fromIntegral k)
|
|
s
|
|
(fromIntegral sq)
|
|
i
|
|
storeSapSpend :: ZcashTransactionId -> (Int, ShieldedSpend) -> ShieldSpend
|
|
storeSapSpend wid (i, sp) =
|
|
ShieldSpend
|
|
wid
|
|
(HexStringDB $ sp_cv sp)
|
|
(HexStringDB $ sp_anchor sp)
|
|
(HexStringDB $ sp_nullifier sp)
|
|
(HexStringDB $ sp_rk sp)
|
|
(HexStringDB $ sp_proof sp)
|
|
(HexStringDB $ sp_auth sp)
|
|
i
|
|
storeSapOutput ::
|
|
ZcashTransactionId -> (Int, ShieldedOutput) -> ShieldOutput
|
|
storeSapOutput wid (i, so) =
|
|
ShieldOutput
|
|
wid
|
|
(HexStringDB $ s_cv so)
|
|
(HexStringDB $ s_cmu so)
|
|
(HexStringDB $ s_ephKey so)
|
|
(HexStringDB $ s_encCipherText so)
|
|
(HexStringDB $ s_outCipherText so)
|
|
(HexStringDB $ s_proof so)
|
|
i
|
|
storeOrchAction :: ZcashTransactionId -> (Int, OrchardAction) -> OrchAction
|
|
storeOrchAction wid (i, oa) =
|
|
OrchAction
|
|
wid
|
|
(HexStringDB $ nf oa)
|
|
(HexStringDB $ rk oa)
|
|
(HexStringDB $ cmx oa)
|
|
(HexStringDB $ eph_key oa)
|
|
(HexStringDB $ enc_ciphertext oa)
|
|
(HexStringDB $ out_ciphertext oa)
|
|
(HexStringDB $ cv oa)
|
|
(HexStringDB $ auth oa)
|
|
i
|
|
|
|
-- | Get the transactions from a particular block forward
|
|
getZcashTransactions ::
|
|
ConnectionPool -- ^ The database path
|
|
-> Int -- ^ Block
|
|
-> IO [Entity ZcashTransaction]
|
|
getZcashTransactions pool b =
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
txs <- from $ table @ZcashTransaction
|
|
where_ $ txs ^. ZcashTransactionBlock >. val b
|
|
orderBy [asc $ txs ^. ZcashTransactionBlock]
|
|
return txs
|
|
|
|
-- ** QR codes
|
|
-- | Functions to manage the QR codes stored in the database
|
|
saveQrCode ::
|
|
ConnectionPool -- ^ the connection pool
|
|
-> QrCode
|
|
-> NoLoggingT IO (Maybe (Entity QrCode))
|
|
saveQrCode pool qr =
|
|
PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUniqueEntity qr
|
|
|
|
getQrCodes ::
|
|
ConnectionPool -- ^ the connection pool
|
|
-> WalletAddressId
|
|
-> IO [Entity QrCode]
|
|
getQrCodes pool wId =
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
qrs <- from $ table @QrCode
|
|
where_ $ qrs ^. QrCodeAddress ==. val wId
|
|
return qrs
|
|
|
|
getQrCode :: ConnectionPool -> ZcashPool -> WalletAddressId -> IO (Maybe QrCode)
|
|
getQrCode pool zp wId = do
|
|
r <-
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
selectOne $ do
|
|
qrs <- from $ table @QrCode
|
|
where_ $ qrs ^. QrCodeAddress ==. val wId
|
|
where_ $ qrs ^. QrCodeVersion ==. val zp
|
|
return qrs
|
|
return $ entityVal <$> r
|
|
|
|
-- * Wallet
|
|
-- | Get the block of the last transaction known to the wallet
|
|
getMaxWalletBlock ::
|
|
ConnectionPool -- ^ The database path
|
|
-> IO Int
|
|
getMaxWalletBlock pool = do
|
|
b <-
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
selectOne $ do
|
|
txs <- from $ table @WalletTransaction
|
|
where_ $ txs ^. WalletTransactionBlock >. val 0
|
|
orderBy [desc $ txs ^. WalletTransactionBlock]
|
|
return txs
|
|
case b of
|
|
Nothing -> return $ -1
|
|
Just x -> return $ walletTransactionBlock $ entityVal x
|
|
|
|
getMinBirthdayHeight :: ConnectionPool -> IO Int
|
|
getMinBirthdayHeight pool = do
|
|
b <-
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
selectOne $ do
|
|
w <- from $ table @ZcashWallet
|
|
where_ (w ^. ZcashWalletBirthdayHeight >. val 0)
|
|
orderBy [asc $ w ^. ZcashWalletBirthdayHeight]
|
|
pure w
|
|
case b of
|
|
Nothing -> return 0
|
|
Just x -> return $ zcashWalletBirthdayHeight $ entityVal x
|
|
|
|
getLastSyncBlock :: ConnectionPool -> ZcashWalletId -> IO Int
|
|
getLastSyncBlock pool zw = do
|
|
b <-
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
selectOne $ do
|
|
w <- from $ table @ZcashWallet
|
|
where_ (w ^. ZcashWalletId ==. val zw)
|
|
pure w
|
|
case b of
|
|
Nothing -> throwIO $ userError "Failed to retrieve wallet"
|
|
Just x -> return $ zcashWalletLastSync $ entityVal x
|
|
|
|
-- | Save a @WalletTransaction@
|
|
saveWalletTransaction ::
|
|
ConnectionPool
|
|
-> ZcashAccountId
|
|
-> Entity ZcashTransaction
|
|
-> IO WalletTransactionId
|
|
saveWalletTransaction pool za zt = do
|
|
let zT' = entityVal zt
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
t <-
|
|
upsert
|
|
(WalletTransaction
|
|
(zcashTransactionTxId zT')
|
|
za
|
|
(zcashTransactionBlock zT')
|
|
(zcashTransactionConf zT')
|
|
(zcashTransactionTime zT'))
|
|
[]
|
|
return $ entityKey t
|
|
|
|
-- | Save a @WalletSapNote@
|
|
saveWalletSapNote ::
|
|
ConnectionPool -- ^ The database path
|
|
-> WalletTransactionId -- ^ The index for the transaction that contains the note
|
|
-> Integer -- ^ note position
|
|
-> SaplingWitness -- ^ the Sapling incremental witness
|
|
-> Bool -- ^ change flag
|
|
-> ZcashAccountId
|
|
-> ShieldOutputId
|
|
-> DecodedNote -- The decoded Sapling note
|
|
-> IO ()
|
|
saveWalletSapNote pool wId pos wit ch za zt dn = do
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
_ <-
|
|
upsert
|
|
(WalletSapNote
|
|
wId
|
|
za
|
|
(fromIntegral $ a_value dn)
|
|
(a_recipient dn)
|
|
(T.filter (/= '\NUL') $ TE.decodeUtf8Lenient $ a_memo dn)
|
|
False
|
|
(HexStringDB $ a_nullifier dn)
|
|
(fromIntegral pos)
|
|
(HexStringDB $ sapWit wit)
|
|
ch
|
|
zt
|
|
(RseedDB $ a_rseed dn))
|
|
[]
|
|
return ()
|
|
|
|
-- | Save a @WalletOrchNote@
|
|
saveWalletOrchNote ::
|
|
ConnectionPool
|
|
-> WalletTransactionId
|
|
-> Integer
|
|
-> OrchardWitness
|
|
-> Bool
|
|
-> ZcashAccountId
|
|
-> OrchActionId
|
|
-> DecodedNote
|
|
-> IO ()
|
|
saveWalletOrchNote pool wId pos wit ch za zt dn = do
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
_ <-
|
|
upsert
|
|
(WalletOrchNote
|
|
wId
|
|
za
|
|
(fromIntegral $ a_value dn)
|
|
(a_recipient dn)
|
|
(T.filter (/= '\NUL') $ TE.decodeUtf8Lenient $ a_memo dn)
|
|
False
|
|
(HexStringDB $ a_nullifier dn)
|
|
(fromIntegral pos)
|
|
(HexStringDB $ orchWit wit)
|
|
ch
|
|
zt
|
|
(a_rho dn)
|
|
(RseedDB $ a_rseed dn))
|
|
[]
|
|
return ()
|
|
|
|
-- | Find the Transparent Notes that match the given transparent receiver
|
|
findTransparentNotes ::
|
|
ConnectionPool -- ^ The database path
|
|
-> Int -- ^ Starting block
|
|
-> Entity WalletAddress
|
|
-> IO ()
|
|
findTransparentNotes pool b t = do
|
|
let tReceiver = t_rec =<< readUnifiedAddressDB (entityVal t)
|
|
case tReceiver of
|
|
Just tR -> do
|
|
let s =
|
|
BS.concat
|
|
[ BS.pack [0x76, 0xA9, 0x14]
|
|
, (toBytes . tr_bytes) tR
|
|
, BS.pack [0x88, 0xAC]
|
|
]
|
|
tN <-
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
(txs :& tNotes) <-
|
|
from $ table @ZcashTransaction `innerJoin` table @TransparentNote `on`
|
|
(\(txs :& tNotes) ->
|
|
txs ^. ZcashTransactionId ==. tNotes ^. TransparentNoteTx)
|
|
where_ (txs ^. ZcashTransactionBlock >. val b)
|
|
where_ (tNotes ^. TransparentNoteScript ==. val s)
|
|
pure (txs, tNotes)
|
|
mapM_
|
|
(saveWalletTrNote
|
|
pool
|
|
(getScope $ walletAddressScope $ entityVal t)
|
|
(walletAddressAccId $ entityVal t)
|
|
(entityKey t))
|
|
tN
|
|
Nothing -> return ()
|
|
|
|
-- | Add the transparent notes to the wallet
|
|
saveWalletTrNote ::
|
|
ConnectionPool -- ^ the database path
|
|
-> Scope
|
|
-> ZcashAccountId
|
|
-> WalletAddressId
|
|
-> (Entity ZcashTransaction, Entity TransparentNote)
|
|
-> IO ()
|
|
saveWalletTrNote pool ch za wa (zt, tn) = do
|
|
let zT' = entityVal zt
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
t <-
|
|
upsert
|
|
(WalletTransaction
|
|
(zcashTransactionTxId zT')
|
|
za
|
|
(zcashTransactionBlock zT')
|
|
(zcashTransactionConf zT')
|
|
(zcashTransactionTime zT'))
|
|
[]
|
|
insert_ $
|
|
WalletTrNote
|
|
(entityKey t)
|
|
za
|
|
wa
|
|
(transparentNoteValue $ entityVal tn)
|
|
False
|
|
(transparentNoteScript $ entityVal tn)
|
|
(ch == Internal)
|
|
(fromIntegral $ transparentNotePosition $ entityVal tn)
|
|
|
|
-- | Save a Sapling note to the wallet database
|
|
saveSapNote :: ConnectionPool -> WalletSapNote -> IO ()
|
|
saveSapNote pool wsn =
|
|
runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ insert_ wsn
|
|
|
|
-- | Get the shielded outputs from the given blockheight
|
|
getShieldedOutputs ::
|
|
ConnectionPool -- ^ database path
|
|
-> Int -- ^ block
|
|
-> IO [(Entity ZcashTransaction, Entity ShieldOutput)]
|
|
getShieldedOutputs pool b =
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
(txs :& sOutputs) <-
|
|
from $ table @ZcashTransaction `innerJoin` table @ShieldOutput `on`
|
|
(\(txs :& sOutputs) ->
|
|
txs ^. ZcashTransactionId ==. sOutputs ^. ShieldOutputTx)
|
|
where_ (txs ^. ZcashTransactionBlock >=. val b)
|
|
orderBy
|
|
[ asc $ txs ^. ZcashTransactionId
|
|
, asc $ sOutputs ^. ShieldOutputPosition
|
|
]
|
|
pure (txs, sOutputs)
|
|
|
|
-- | Get the Orchard actions from the given blockheight forward
|
|
getOrchardActions ::
|
|
ConnectionPool -- ^ database path
|
|
-> Int -- ^ block
|
|
-> IO [(Entity ZcashTransaction, Entity OrchAction)]
|
|
getOrchardActions pool b =
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
(txs :& oActions) <-
|
|
from $ table @ZcashTransaction `innerJoin` table @OrchAction `on`
|
|
(\(txs :& oActions) ->
|
|
txs ^. ZcashTransactionId ==. oActions ^. OrchActionTx)
|
|
where_ (txs ^. ZcashTransactionBlock >=. val b)
|
|
orderBy
|
|
[asc $ txs ^. ZcashTransactionId, asc $ oActions ^. OrchActionPosition]
|
|
pure (txs, oActions)
|
|
|
|
-- | Get the transactions belonging to the given address
|
|
getWalletTransactions ::
|
|
ConnectionPool -- ^ database path
|
|
-> Entity WalletAddress
|
|
-> NoLoggingT IO ()
|
|
getWalletTransactions pool w = do
|
|
let w' = entityVal w
|
|
chgAddr <- getInternalAddresses pool $ walletAddressAccId $ entityVal w
|
|
let ctReceiver = t_rec =<< readUnifiedAddressDB (entityVal $ head chgAddr)
|
|
let csReceiver = s_rec =<< readUnifiedAddressDB (entityVal $ head chgAddr)
|
|
let coReceiver = o_rec =<< readUnifiedAddressDB (entityVal $ head chgAddr)
|
|
let tReceiver = t_rec =<< readUnifiedAddressDB w'
|
|
let sReceiver = s_rec =<< readUnifiedAddressDB w'
|
|
let oReceiver = o_rec =<< readUnifiedAddressDB w'
|
|
trNotes <-
|
|
case tReceiver of
|
|
Nothing -> return []
|
|
Just tR -> do
|
|
let s =
|
|
BS.concat
|
|
[ BS.pack [0x76, 0xA9, 0x14]
|
|
, (toBytes . tr_bytes) tR
|
|
, BS.pack [0x88, 0xAC]
|
|
]
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
tnotes <- from $ table @WalletTrNote
|
|
where_ (tnotes ^. WalletTrNoteScript ==. val s)
|
|
pure tnotes
|
|
trChgNotes <-
|
|
case ctReceiver of
|
|
Nothing -> return []
|
|
Just tR -> do
|
|
let s1 =
|
|
BS.concat
|
|
[ BS.pack [0x76, 0xA9, 0x14]
|
|
, (toBytes . tr_bytes) tR
|
|
, BS.pack [0x88, 0xAC]
|
|
]
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
tnotes <- from $ table @WalletTrNote
|
|
where_ (tnotes ^. WalletTrNoteScript ==. val s1)
|
|
pure tnotes
|
|
trSpends <-
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
trSpends <- from $ table @WalletTrSpend
|
|
where_
|
|
(trSpends ^. WalletTrSpendNote `in_`
|
|
valList (map entityKey (trNotes <> trChgNotes)))
|
|
pure trSpends
|
|
sapNotes <-
|
|
case sReceiver of
|
|
Nothing -> return []
|
|
Just sR -> do
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
snotes <- from $ table @WalletSapNote
|
|
where_ (snotes ^. WalletSapNoteRecipient ==. val (getBytes sR))
|
|
pure snotes
|
|
sapChgNotes <-
|
|
case csReceiver of
|
|
Nothing -> return []
|
|
Just sR -> do
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
snotes <- from $ table @WalletSapNote
|
|
where_ (snotes ^. WalletSapNoteRecipient ==. val (getBytes sR))
|
|
pure snotes
|
|
sapSpends <- mapM (getSapSpends . entityKey) (sapNotes <> sapChgNotes)
|
|
orchNotes <-
|
|
case oReceiver of
|
|
Nothing -> return []
|
|
Just oR -> do
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
onotes <- from $ table @WalletOrchNote
|
|
where_ (onotes ^. WalletOrchNoteRecipient ==. val (getBytes oR))
|
|
pure onotes
|
|
orchChgNotes <-
|
|
case coReceiver of
|
|
Nothing -> return []
|
|
Just oR -> do
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
onotes <- from $ table @WalletOrchNote
|
|
where_ (onotes ^. WalletOrchNoteRecipient ==. val (getBytes oR))
|
|
pure onotes
|
|
orchSpends <- mapM (getOrchSpends . entityKey) (orchNotes <> orchChgNotes)
|
|
clearUserTx (entityKey w)
|
|
mapM_ addTr trNotes
|
|
mapM_ addTr trChgNotes
|
|
mapM_ addSap sapNotes
|
|
mapM_ addSap sapChgNotes
|
|
mapM_ addOrch orchNotes
|
|
mapM_ addOrch orchChgNotes
|
|
mapM_ subTSpend trSpends
|
|
mapM_ subSSpend $ catMaybes sapSpends
|
|
mapM_ subOSpend $ catMaybes orchSpends
|
|
where
|
|
clearUserTx :: WalletAddressId -> NoLoggingT IO ()
|
|
clearUserTx waId = do
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
delete $ do
|
|
u <- from $ table @UserTx
|
|
where_ (u ^. UserTxAddress ==. val waId)
|
|
return ()
|
|
getSapSpends ::
|
|
WalletSapNoteId -> NoLoggingT IO (Maybe (Entity WalletSapSpend))
|
|
getSapSpends n = do
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
selectOne $ do
|
|
sapSpends <- from $ table @WalletSapSpend
|
|
where_ (sapSpends ^. WalletSapSpendNote ==. val n)
|
|
pure sapSpends
|
|
getOrchSpends ::
|
|
WalletOrchNoteId -> NoLoggingT IO (Maybe (Entity WalletOrchSpend))
|
|
getOrchSpends n = do
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
selectOne $ do
|
|
orchSpends <- from $ table @WalletOrchSpend
|
|
where_ (orchSpends ^. WalletOrchSpendNote ==. val n)
|
|
pure orchSpends
|
|
addTr :: Entity WalletTrNote -> NoLoggingT IO ()
|
|
addTr n =
|
|
upsertUserTx
|
|
(walletTrNoteTx $ entityVal n)
|
|
(entityKey w)
|
|
(fromIntegral $ walletTrNoteValue $ entityVal n)
|
|
""
|
|
addSap :: Entity WalletSapNote -> NoLoggingT IO ()
|
|
addSap n =
|
|
upsertUserTx
|
|
(walletSapNoteTx $ entityVal n)
|
|
(entityKey w)
|
|
(fromIntegral $ walletSapNoteValue $ entityVal n)
|
|
(walletSapNoteMemo $ entityVal n)
|
|
addOrch :: Entity WalletOrchNote -> NoLoggingT IO ()
|
|
addOrch n =
|
|
upsertUserTx
|
|
(walletOrchNoteTx $ entityVal n)
|
|
(entityKey w)
|
|
(fromIntegral $ walletOrchNoteValue $ entityVal n)
|
|
(walletOrchNoteMemo $ entityVal n)
|
|
subTSpend :: Entity WalletTrSpend -> NoLoggingT IO ()
|
|
subTSpend n =
|
|
upsertUserTx
|
|
(walletTrSpendTx $ entityVal n)
|
|
(entityKey w)
|
|
(-(fromIntegral $ walletTrSpendValue $ entityVal n))
|
|
""
|
|
subSSpend :: Entity WalletSapSpend -> NoLoggingT IO ()
|
|
subSSpend n =
|
|
upsertUserTx
|
|
(walletSapSpendTx $ entityVal n)
|
|
(entityKey w)
|
|
(-(fromIntegral $ walletSapSpendValue $ entityVal n))
|
|
""
|
|
subOSpend :: Entity WalletOrchSpend -> NoLoggingT IO ()
|
|
subOSpend n =
|
|
upsertUserTx
|
|
(walletOrchSpendTx $ entityVal n)
|
|
(entityKey w)
|
|
(-(fromIntegral $ walletOrchSpendValue $ entityVal n))
|
|
""
|
|
upsertUserTx ::
|
|
WalletTransactionId
|
|
-> WalletAddressId
|
|
-> Int
|
|
-> T.Text
|
|
-> NoLoggingT IO ()
|
|
upsertUserTx tId wId amt memo = do
|
|
tr <-
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
tx <- from $ table @WalletTransaction
|
|
where_ (tx ^. WalletTransactionId ==. val tId)
|
|
pure tx
|
|
existingUtx <-
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
selectOne $ do
|
|
ut <- from $ table @UserTx
|
|
where_
|
|
(ut ^. UserTxHex ==.
|
|
val (walletTransactionTxId $ entityVal $ head tr))
|
|
where_ (ut ^. UserTxAddress ==. val wId)
|
|
pure ut
|
|
case existingUtx of
|
|
Nothing -> do
|
|
_ <-
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
upsert
|
|
(UserTx
|
|
(walletTransactionTxId $ entityVal $ head tr)
|
|
wId
|
|
(walletTransactionTime $ entityVal $ head tr)
|
|
amt
|
|
memo)
|
|
[]
|
|
return ()
|
|
Just uTx -> do
|
|
_ <-
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
update $ \t -> do
|
|
set
|
|
t
|
|
[ UserTxAmount +=. val amt
|
|
, UserTxMemo =.
|
|
val (memo <> " " <> userTxMemo (entityVal uTx))
|
|
]
|
|
where_ (t ^. UserTxId ==. val (entityKey uTx))
|
|
return ()
|
|
|
|
getUserTx :: ConnectionPool -> WalletAddressId -> IO [Entity UserTx]
|
|
getUserTx pool aId = do
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
uTxs <- from $ table @UserTx
|
|
where_ (uTxs ^. UserTxAddress ==. val aId)
|
|
orderBy [asc $ uTxs ^. UserTxTime]
|
|
return uTxs
|
|
|
|
-- | Get wallet transparent notes by account
|
|
getWalletTrNotes :: ConnectionPool -> ZcashAccountId -> IO [Entity WalletTrNote]
|
|
getWalletTrNotes pool za = do
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
n <- from $ table @WalletTrNote
|
|
where_ (n ^. WalletTrNoteAccId ==. val za)
|
|
pure n
|
|
|
|
-- | find Transparent spends
|
|
findTransparentSpends :: ConnectionPool -> ZcashAccountId -> IO ()
|
|
findTransparentSpends pool za = do
|
|
notes <- getWalletTrNotes pool za
|
|
mapM_ findOneTrSpend notes
|
|
where
|
|
findOneTrSpend :: Entity WalletTrNote -> IO ()
|
|
findOneTrSpend n = do
|
|
mReverseTxId <-
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
selectOne $ do
|
|
wtx <- from $ table @WalletTransaction
|
|
where_
|
|
(wtx ^. WalletTransactionId ==. val (walletTrNoteTx $ entityVal n))
|
|
pure $ wtx ^. WalletTransactionTxId
|
|
case mReverseTxId of
|
|
Nothing -> throwIO $ userError "failed to get tx ID"
|
|
Just (Value reverseTxId) -> do
|
|
let flipTxId =
|
|
HexStringDB $
|
|
HexString $ BS.reverse $ toBytes $ getHex reverseTxId
|
|
s <-
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
(tx :& trSpends) <-
|
|
from $
|
|
table @ZcashTransaction `innerJoin` table @TransparentSpend `on`
|
|
(\(tx :& trSpends) ->
|
|
tx ^. ZcashTransactionId ==. trSpends ^. TransparentSpendTx)
|
|
where_
|
|
(trSpends ^. TransparentSpendOutPointHash ==. val flipTxId)
|
|
where_
|
|
(trSpends ^. TransparentSpendOutPointIndex ==.
|
|
val (walletTrNotePosition $ entityVal n))
|
|
pure (tx, trSpends)
|
|
if null s
|
|
then return ()
|
|
else do
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
_ <-
|
|
update $ \w -> do
|
|
set w [WalletTrNoteSpent =. val True]
|
|
where_ $ w ^. WalletTrNoteId ==. val (entityKey n)
|
|
t' <- upsertWalTx (entityVal $ fst $ head s) za
|
|
_ <-
|
|
upsert
|
|
(WalletTrSpend
|
|
(entityKey t')
|
|
(entityKey n)
|
|
za
|
|
(walletTrNoteValue $ entityVal n))
|
|
[]
|
|
return ()
|
|
|
|
getWalletSapNotes ::
|
|
ConnectionPool -> ZcashAccountId -> IO [Entity WalletSapNote]
|
|
getWalletSapNotes pool za = do
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
n <- from $ table @WalletSapNote
|
|
where_ (n ^. WalletSapNoteAccId ==. val za)
|
|
pure n
|
|
|
|
-- | Sapling DAG-aware spend tracking
|
|
findSapSpends ::
|
|
ConnectionPool -> ZcashAccountId -> [Entity WalletSapNote] -> IO ()
|
|
findSapSpends _ _ [] = return ()
|
|
findSapSpends pool za (n:notes) = do
|
|
s <-
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
(tx :& sapSpends) <-
|
|
from $ table @ZcashTransaction `innerJoin` table @ShieldSpend `on`
|
|
(\(tx :& sapSpends) ->
|
|
tx ^. ZcashTransactionId ==. sapSpends ^. ShieldSpendTx)
|
|
where_
|
|
(sapSpends ^. ShieldSpendNullifier ==.
|
|
val (walletSapNoteNullifier (entityVal n)))
|
|
pure (tx, sapSpends)
|
|
if null s
|
|
then findSapSpends pool za notes
|
|
else do
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
_ <-
|
|
update $ \w -> do
|
|
set w [WalletSapNoteSpent =. val True]
|
|
where_ $ w ^. WalletSapNoteId ==. val (entityKey n)
|
|
t' <- upsertWalTx (entityVal $ fst $ head s) za
|
|
_ <-
|
|
upsert
|
|
(WalletSapSpend
|
|
(entityKey t')
|
|
(entityKey n)
|
|
za
|
|
(walletSapNoteValue $ entityVal n))
|
|
[]
|
|
return ()
|
|
findSapSpends pool za notes
|
|
|
|
getWalletOrchNotes ::
|
|
ConnectionPool -> ZcashAccountId -> IO [Entity WalletOrchNote]
|
|
getWalletOrchNotes pool za = do
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
n <- from $ table @WalletOrchNote
|
|
where_ (n ^. WalletOrchNoteAccId ==. val za)
|
|
pure n
|
|
|
|
getUnspentSapNotes :: ConnectionPool -> IO [Entity WalletSapNote]
|
|
getUnspentSapNotes pool = do
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
n <- from $ table @WalletSapNote
|
|
where_ (n ^. WalletSapNoteSpent ==. val False)
|
|
pure n
|
|
|
|
getSaplingCmus :: Pool SqlBackend -> ShieldOutputId -> IO [Value HexStringDB]
|
|
getSaplingCmus pool zt = do
|
|
PS.runSqlPool
|
|
(select $ do
|
|
n <- from $ table @ShieldOutput
|
|
where_ (n ^. ShieldOutputId >. val zt)
|
|
orderBy [asc $ n ^. ShieldOutputId]
|
|
pure $ n ^. ShieldOutputCmu)
|
|
pool
|
|
|
|
getMaxSaplingNote :: Pool SqlBackend -> IO ShieldOutputId
|
|
getMaxSaplingNote pool = do
|
|
flip PS.runSqlPool pool $ do
|
|
x <-
|
|
selectOne $ do
|
|
n <- from $ table @ShieldOutput
|
|
where_ (n ^. ShieldOutputId >. val (toSqlKey 0))
|
|
orderBy [desc $ n ^. ShieldOutputId]
|
|
pure (n ^. ShieldOutputId)
|
|
case x of
|
|
Nothing -> return $ toSqlKey 0
|
|
Just (Value y) -> return y
|
|
|
|
updateSapNoteRecord ::
|
|
Pool SqlBackend
|
|
-> WalletSapNoteId
|
|
-> SaplingWitness
|
|
-> ShieldOutputId
|
|
-> IO ()
|
|
updateSapNoteRecord pool n w o = do
|
|
flip PS.runSqlPool pool $ do
|
|
update $ \x -> do
|
|
set
|
|
x
|
|
[ WalletSapNoteWitness =. val (HexStringDB $ sapWit w)
|
|
, WalletSapNoteWitPos =. val o
|
|
]
|
|
where_ (x ^. WalletSapNoteId ==. val n)
|
|
|
|
getUnspentOrchNotes :: ConnectionPool -> IO [Entity WalletOrchNote]
|
|
getUnspentOrchNotes pool = do
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
n <- from $ table @WalletOrchNote
|
|
where_ (n ^. WalletOrchNoteSpent ==. val False)
|
|
pure n
|
|
|
|
getOrchardCmxs :: Pool SqlBackend -> OrchActionId -> IO [Value HexStringDB]
|
|
getOrchardCmxs pool zt = do
|
|
PS.runSqlPool
|
|
(select $ do
|
|
n <- from $ table @OrchAction
|
|
where_ (n ^. OrchActionId >. val zt)
|
|
orderBy [asc $ n ^. OrchActionId]
|
|
pure $ n ^. OrchActionCmx)
|
|
pool
|
|
|
|
getMaxOrchardNote :: Pool SqlBackend -> IO OrchActionId
|
|
getMaxOrchardNote pool = do
|
|
flip PS.runSqlPool pool $ do
|
|
x <-
|
|
selectOne $ do
|
|
n <- from $ table @OrchAction
|
|
where_ (n ^. OrchActionId >. val (toSqlKey 0))
|
|
orderBy [desc $ n ^. OrchActionId]
|
|
pure (n ^. OrchActionId)
|
|
case x of
|
|
Nothing -> return $ toSqlKey 0
|
|
Just (Value y) -> return y
|
|
|
|
updateOrchNoteRecord ::
|
|
Pool SqlBackend
|
|
-> WalletOrchNoteId
|
|
-> OrchardWitness
|
|
-> OrchActionId
|
|
-> IO ()
|
|
updateOrchNoteRecord pool n w o = do
|
|
flip PS.runSqlPool pool $ do
|
|
update $ \x -> do
|
|
set
|
|
x
|
|
[ WalletOrchNoteWitness =. val (HexStringDB $ orchWit w)
|
|
, WalletOrchNoteWitPos =. val o
|
|
]
|
|
where_ (x ^. WalletOrchNoteId ==. val n)
|
|
|
|
findOrchSpends ::
|
|
ConnectionPool -> ZcashAccountId -> [Entity WalletOrchNote] -> IO ()
|
|
findOrchSpends _ _ [] = return ()
|
|
findOrchSpends pool za (n:notes) = do
|
|
s <-
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
(tx :& orchSpends) <-
|
|
from $ table @ZcashTransaction `innerJoin` table @OrchAction `on`
|
|
(\(tx :& orchSpends) ->
|
|
tx ^. ZcashTransactionId ==. orchSpends ^. OrchActionTx)
|
|
where_
|
|
(orchSpends ^. OrchActionNf ==.
|
|
val (walletOrchNoteNullifier (entityVal n)))
|
|
pure (tx, orchSpends)
|
|
if null s
|
|
then findOrchSpends pool za notes
|
|
else do
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
_ <-
|
|
update $ \w -> do
|
|
set w [WalletOrchNoteSpent =. val True]
|
|
where_ $ w ^. WalletOrchNoteId ==. val (entityKey n)
|
|
t' <- upsertWalTx (entityVal $ fst $ head s) za
|
|
_ <-
|
|
upsert
|
|
(WalletOrchSpend
|
|
(entityKey t')
|
|
(entityKey n)
|
|
za
|
|
(walletOrchNoteValue $ entityVal n))
|
|
[]
|
|
return ()
|
|
findOrchSpends pool za notes
|
|
|
|
upsertWalTx ::
|
|
MonadIO m
|
|
=> ZcashTransaction
|
|
-> ZcashAccountId
|
|
-> SqlPersistT m (Entity WalletTransaction)
|
|
upsertWalTx zt za =
|
|
upsert
|
|
(WalletTransaction
|
|
(zcashTransactionTxId zt)
|
|
za
|
|
(zcashTransactionBlock zt)
|
|
(zcashTransactionConf zt)
|
|
(zcashTransactionTime zt))
|
|
[]
|
|
|
|
getBalance :: ConnectionPool -> ZcashAccountId -> IO Integer
|
|
getBalance pool za = do
|
|
trNotes <- getWalletUnspentTrNotes pool za
|
|
let tAmts = map (walletTrNoteValue . entityVal) trNotes
|
|
let tBal = sum tAmts
|
|
sapNotes <- getWalletUnspentSapNotes pool za
|
|
let sAmts = map (walletSapNoteValue . entityVal) sapNotes
|
|
let sBal = sum sAmts
|
|
orchNotes <- getWalletUnspentOrchNotes pool za
|
|
let oAmts = map (walletOrchNoteValue . entityVal) orchNotes
|
|
let oBal = sum oAmts
|
|
return . fromIntegral $ tBal + sBal + oBal
|
|
|
|
getUnconfirmedBalance :: ConnectionPool -> ZcashAccountId -> IO Integer
|
|
getUnconfirmedBalance pool za = do
|
|
trNotes <- getWalletUnspentUnconfirmedTrNotes pool za
|
|
let tAmts = map (walletTrNoteValue . entityVal) trNotes
|
|
let tBal = sum tAmts
|
|
sapNotes <- getWalletUnspentUnconfirmedSapNotes pool za
|
|
let sAmts = map (walletSapNoteValue . entityVal) sapNotes
|
|
let sBal = sum sAmts
|
|
orchNotes <- getWalletUnspentUnconfirmedOrchNotes pool za
|
|
let oAmts = map (walletOrchNoteValue . entityVal) orchNotes
|
|
let oBal = sum oAmts
|
|
return . fromIntegral $ tBal + sBal + oBal
|
|
|
|
clearWalletTransactions :: ConnectionPool -> IO ()
|
|
clearWalletTransactions pool = do
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
delete $ do
|
|
_ <- from $ table @UserTx
|
|
return ()
|
|
delete $ do
|
|
_ <- from $ table @WalletOrchSpend
|
|
return ()
|
|
delete $ do
|
|
_ <- from $ table @WalletOrchNote
|
|
return ()
|
|
delete $ do
|
|
_ <- from $ table @WalletSapSpend
|
|
return ()
|
|
delete $ do
|
|
_ <- from $ table @WalletSapNote
|
|
return ()
|
|
delete $ do
|
|
_ <- from $ table @WalletTrNote
|
|
return ()
|
|
delete $ do
|
|
_ <- from $ table @WalletTrSpend
|
|
return ()
|
|
delete $ do
|
|
_ <- from $ table @WalletTransaction
|
|
return ()
|
|
|
|
getWalletUnspentTrNotes ::
|
|
ConnectionPool -> ZcashAccountId -> IO [Entity WalletTrNote]
|
|
getWalletUnspentTrNotes pool za = do
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
(txs :& tNotes) <-
|
|
from $ table @WalletTransaction `innerJoin` table @WalletTrNote `on`
|
|
(\(txs :& tNotes) ->
|
|
txs ^. WalletTransactionId ==. tNotes ^. WalletTrNoteTx)
|
|
where_ (tNotes ^. WalletTrNoteAccId ==. val za)
|
|
where_ (tNotes ^. WalletTrNoteSpent ==. val False)
|
|
where_
|
|
((tNotes ^. WalletTrNoteChange ==. val True &&. txs ^.
|
|
WalletTransactionConf >=.
|
|
val 3) ||.
|
|
(tNotes ^. WalletTrNoteChange ==. val False &&. txs ^.
|
|
WalletTransactionConf >=.
|
|
val 10))
|
|
pure tNotes
|
|
|
|
getWalletUnspentUnconfirmedTrNotes ::
|
|
ConnectionPool -> ZcashAccountId -> IO [Entity WalletTrNote]
|
|
getWalletUnspentUnconfirmedTrNotes pool za = do
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
(txs :& tNotes) <-
|
|
from $ table @WalletTransaction `innerJoin` table @WalletTrNote `on`
|
|
(\(txs :& tNotes) ->
|
|
txs ^. WalletTransactionId ==. tNotes ^. WalletTrNoteTx)
|
|
where_ (tNotes ^. WalletTrNoteAccId ==. val za)
|
|
where_ (tNotes ^. WalletTrNoteSpent ==. val False)
|
|
where_
|
|
((tNotes ^. WalletTrNoteChange ==. val True &&. txs ^.
|
|
WalletTransactionConf <.
|
|
val 3) ||.
|
|
(tNotes ^. WalletTrNoteChange ==. val False &&. txs ^.
|
|
WalletTransactionConf <.
|
|
val 10))
|
|
pure tNotes
|
|
|
|
getWalletUnspentSapNotes ::
|
|
ConnectionPool -> ZcashAccountId -> IO [Entity WalletSapNote]
|
|
getWalletUnspentSapNotes pool za = do
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
(txs :& sNotes) <-
|
|
from $ table @WalletTransaction `innerJoin` table @WalletSapNote `on`
|
|
(\(txs :& sNotes) ->
|
|
txs ^. WalletTransactionId ==. sNotes ^. WalletSapNoteTx)
|
|
where_ (sNotes ^. WalletSapNoteAccId ==. val za)
|
|
where_ (sNotes ^. WalletSapNoteSpent ==. val False)
|
|
where_
|
|
((sNotes ^. WalletSapNoteChange ==. val True &&. txs ^.
|
|
WalletTransactionConf >=.
|
|
val 3) ||.
|
|
(sNotes ^. WalletSapNoteChange ==. val False &&. txs ^.
|
|
WalletTransactionConf >=.
|
|
val 10))
|
|
pure sNotes
|
|
|
|
getWalletUnspentUnconfirmedSapNotes ::
|
|
ConnectionPool -> ZcashAccountId -> IO [Entity WalletSapNote]
|
|
getWalletUnspentUnconfirmedSapNotes pool za = do
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
(txs :& sNotes) <-
|
|
from $ table @WalletTransaction `innerJoin` table @WalletSapNote `on`
|
|
(\(txs :& sNotes) ->
|
|
txs ^. WalletTransactionId ==. sNotes ^. WalletSapNoteTx)
|
|
where_ (sNotes ^. WalletSapNoteAccId ==. val za)
|
|
where_ (sNotes ^. WalletSapNoteSpent ==. val False)
|
|
where_
|
|
((sNotes ^. WalletSapNoteChange ==. val True &&. txs ^.
|
|
WalletTransactionConf <.
|
|
val 3) ||.
|
|
(sNotes ^. WalletSapNoteChange ==. val False &&. txs ^.
|
|
WalletTransactionConf <.
|
|
val 10))
|
|
pure sNotes
|
|
|
|
getWalletUnspentOrchNotes ::
|
|
ConnectionPool -> ZcashAccountId -> IO [Entity WalletOrchNote]
|
|
getWalletUnspentOrchNotes pool za = do
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
(txs :& oNotes) <-
|
|
from $ table @WalletTransaction `innerJoin` table @WalletOrchNote `on`
|
|
(\(txs :& oNotes) ->
|
|
txs ^. WalletTransactionId ==. oNotes ^. WalletOrchNoteTx)
|
|
where_ (oNotes ^. WalletOrchNoteAccId ==. val za)
|
|
where_ (oNotes ^. WalletOrchNoteSpent ==. val False)
|
|
where_
|
|
((oNotes ^. WalletOrchNoteChange ==. val True &&. txs ^.
|
|
WalletTransactionConf >=.
|
|
val 3) ||.
|
|
(oNotes ^. WalletOrchNoteChange ==. val False &&. txs ^.
|
|
WalletTransactionConf >=.
|
|
val 10))
|
|
pure oNotes
|
|
|
|
getWalletUnspentUnconfirmedOrchNotes ::
|
|
ConnectionPool -> ZcashAccountId -> IO [Entity WalletOrchNote]
|
|
getWalletUnspentUnconfirmedOrchNotes pool za = do
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
select $ do
|
|
(txs :& oNotes) <-
|
|
from $ table @WalletTransaction `innerJoin` table @WalletOrchNote `on`
|
|
(\(txs :& oNotes) ->
|
|
txs ^. WalletTransactionId ==. oNotes ^. WalletOrchNoteTx)
|
|
where_ (oNotes ^. WalletOrchNoteAccId ==. val za)
|
|
where_ (oNotes ^. WalletOrchNoteSpent ==. val False)
|
|
where_
|
|
((oNotes ^. WalletOrchNoteChange ==. val True &&. txs ^.
|
|
WalletTransactionConf <.
|
|
val 3) ||.
|
|
(oNotes ^. WalletOrchNoteChange ==. val False &&. txs ^.
|
|
WalletTransactionConf <.
|
|
val 10))
|
|
pure oNotes
|
|
|
|
selectUnspentNotes ::
|
|
ConnectionPool
|
|
-> ZcashAccountId
|
|
-> Integer
|
|
-> IO ([Entity WalletTrNote], [Entity WalletSapNote], [Entity WalletOrchNote])
|
|
selectUnspentNotes pool za amt = do
|
|
trNotes <- getWalletUnspentTrNotes pool za
|
|
let (a1, tList) = checkTransparent (fromIntegral amt) trNotes
|
|
if a1 > 0
|
|
then do
|
|
sapNotes <- getWalletUnspentSapNotes pool za
|
|
let (a2, sList) = checkSapling a1 sapNotes
|
|
if a2 > 0
|
|
then do
|
|
orchNotes <- getWalletUnspentOrchNotes pool za
|
|
let (a3, oList) = checkOrchard a2 orchNotes
|
|
if a3 > 0
|
|
then throwIO $ userError "Not enough funds"
|
|
else return (tList, sList, oList)
|
|
else return (tList, sList, [])
|
|
else return (tList, [], [])
|
|
where
|
|
checkTransparent ::
|
|
Word64 -> [Entity WalletTrNote] -> (Word64, [Entity WalletTrNote])
|
|
checkTransparent x [] = (x, [])
|
|
checkTransparent x (n:ns) =
|
|
if walletTrNoteValue (entityVal n) < x
|
|
then ( fst (checkTransparent (x - walletTrNoteValue (entityVal n)) ns)
|
|
, n :
|
|
snd (checkTransparent (x - walletTrNoteValue (entityVal n)) ns))
|
|
else (0, [n])
|
|
checkSapling ::
|
|
Word64 -> [Entity WalletSapNote] -> (Word64, [Entity WalletSapNote])
|
|
checkSapling x [] = (x, [])
|
|
checkSapling x (n:ns) =
|
|
if walletSapNoteValue (entityVal n) < x
|
|
then ( fst (checkSapling (x - walletSapNoteValue (entityVal n)) ns)
|
|
, n : snd (checkSapling (x - walletSapNoteValue (entityVal n)) ns))
|
|
else (0, [n])
|
|
checkOrchard ::
|
|
Word64 -> [Entity WalletOrchNote] -> (Word64, [Entity WalletOrchNote])
|
|
checkOrchard x [] = (x, [])
|
|
checkOrchard x (n:ns) =
|
|
if walletOrchNoteValue (entityVal n) < x
|
|
then ( fst (checkOrchard (x - walletOrchNoteValue (entityVal n)) ns)
|
|
, n : snd (checkOrchard (x - walletOrchNoteValue (entityVal n)) ns))
|
|
else (0, [n])
|
|
|
|
getWalletTxId ::
|
|
ConnectionPool -> WalletTransactionId -> IO (Maybe (Value HexStringDB))
|
|
getWalletTxId pool wId = do
|
|
runNoLoggingT $
|
|
PS.retryOnBusy $
|
|
flip PS.runSqlPool pool $ do
|
|
selectOne $ do
|
|
wtx <- from $ table @WalletTransaction
|
|
where_ (wtx ^. WalletTransactionId ==. val wId)
|
|
pure $ wtx ^. WalletTransactionTxId
|
|
|
|
-- | Helper function to extract a Unified Address from the database
|
|
readUnifiedAddressDB :: WalletAddress -> Maybe UnifiedAddress
|
|
readUnifiedAddressDB =
|
|
isValidUnifiedAddress . TE.encodeUtf8 . getUA . walletAddressUAddress
|
|
|
|
rmdups :: Ord a => [a] -> [a]
|
|
rmdups = map head . group . sort
|