Vergara_Tech/zenith
Vergara_Tech/zenith
2
0
Fork 0
Code Issues 24 Pull requests Projects Releases 6 Packages Wiki Activity

Implement background sync

Browse source
This commit is contained in:
Rene Vergara 2024-05-05 09:49:55 -05:00
parent 1ba188ec24
commit dcbb2fac4a
Signed by: pitmutt
GPG key ID: 65122AD495A7F5B2
7 changed files with 916 additions and 687 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
app/Main.hs
View file

@ -18,7 +18,7 @@ import System.IO
import Text.Read (readMaybe)
import ZcashHaskell.Types
import Zenith.CLI
import Zenith.Core (clearSync, testSend, testSync)
import Zenith.Core (clearSync, testSync)
import Zenith.Types (Config(..), ZcashAddress(..), ZcashPool(..), ZcashTx(..))
import Zenith.Utils
import Zenith.Zcashd
@ -223,7 +223,6 @@ main = do
"cli" -> runZenithCLI myConfig
"sync" -> testSync myConfig
"rescan" -> clearSync myConfig
"testsend" -> testSend
_ -> printUsage
else printUsage

3
app/ZenScan.hs
View file

@ -2,6 +2,7 @@
module ZenScan where
import Control.Monad.Logger (runNoLoggingT)
import Data.Configurator
import Zenith.Scanner (scanZebra)
@ -11,4 +12,4 @@ main = do
dbFilePath <- require config "dbFilePath"
zebraPort <- require config "zebraPort"
zebraHost <- require config "zebraHost"
scanZebra 2762066 zebraHost zebraPort dbFilePath
runNoLoggingT $ scanZebra 2762066 zebraHost zebraPort dbFilePath

278
src/Zenith/CLI.hs
View file

@ -55,7 +55,7 @@ import Control.Concurrent (forkIO, threadDelay)
import Control.Exception (catch, throw, throwIO, try)
import Control.Monad (forever, void)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (runFileLoggingT)
import Control.Monad.Logger (LoggingT, runFileLoggingT, runNoLoggingT)
import Data.Aeson
import Data.Maybe
import qualified Data.Text as T
@ -63,11 +63,13 @@ import qualified Data.Text.Encoding as E
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import qualified Data.Vector as Vec
import Database.Persist
import Database.Persist.Sqlite
import qualified Graphics.Vty as V
import qualified Graphics.Vty.CrossPlatform as VC
import Lens.Micro ((&), (.~), (^.), set)
import Lens.Micro.Mtl
import Lens.Micro.TH
import System.Hclip
import Text.Wrap (FillScope(..), FillStrategy(..), WrapSettings(..), wrapText)
import ZcashHaskell.Keys (generateWalletSeedPhrase, getWalletSeed)
import ZcashHaskell.Orchard (getSaplingFromUA, isValidUnifiedAddress)
@ -116,8 +118,9 @@ data DisplayType
| SyncDisplay
| BlankDisplay
data Tick =
Tick
data Tick
= TickVal !Float
| TickMsg !String
data State = State
{ _network :: !ZcashNet
@ -140,6 +143,7 @@ data State = State
, _balance :: !Integer
, _barValue :: !Float
, _eventDispatch :: !(BC.BChan Tick)
, _timer :: !Int
}
makeLenses ''State
@ -185,6 +189,7 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s]
, capCommand "A" "ccounts"
, capCommand "V" "iew address"
, capCommand "Q" "uit"
, str $ show (st ^. timer)
])
listBox :: Show e => String -> L.List Name e -> Widget Name
listBox titleLabel l =
@ -218,7 +223,12 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s]
(B.borderWithLabel (str titleLabel) $
hLimit 40 $ vLimit 15 $ L.renderList listDrawAddress True a)
, str " "
, C.hCenter $ str "Use arrows to select"
, C.hCenter
(hBox
[ capCommand "↑↓ " "move"
, capCommand "↲ " "select"
, capCommand "Tab " "->"
])
]
listTxBox :: String -> L.List Name (Entity UserTx) -> Widget Name
listTxBox titleLabel tx =
@ -228,7 +238,12 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s]
(B.borderWithLabel (str titleLabel) $
hLimit 40 $ vLimit 15 $ L.renderList listDrawTx True tx)
, str " "
, C.hCenter $ str "Use arrows to select"
, C.hCenter
(hBox
[ capCommand "↑↓ " "move"
, capCommand "T" "x Display"
, capCommand "Tab " "<-"
])
]
helpDialog :: State -> Widget Name
helpDialog st =
@ -337,7 +352,15 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s]
t_rec =<<
(isValidUnifiedAddress .
E.encodeUtf8 . getUA . walletAddressUAddress)
(entityVal a)))
(entityVal a)) <=>
C.hCenter
(hBox
[ str "Copy: "
, capCommand "U" "nified"
, capCommand "S" "apling"
, capCommand "T" "ransparent"
]) <=>
C.hCenter xCommand)
Nothing -> emptyWidget
PhraseDisplay ->
case L.listSelectedElement $ st ^. wallets of
@ -481,60 +504,49 @@ barToDoAttr = A.attrName "remaining"
validBarValue :: Float -> Float
validBarValue = clamp 0 1
scanZebra :: Int -> BT.EventM Name State ()
scanZebra b = do
s <- BT.get
_ <- liftIO $ initDb $ s ^. dbPath
bStatus <- liftIO $ checkBlockChain (s ^. zebraHost) (s ^. zebraPort)
dbBlock <- liftIO $ getMaxBlock $ s ^. dbPath
scanZebra :: T.Text -> T.Text -> Int -> Int -> BC.BChan Tick -> IO ()
scanZebra dbP zHost zPort b eChan = do
_ <- liftIO $ initDb dbP
bStatus <- liftIO $ checkBlockChain zHost zPort
pool <- runNoLoggingT $ initPool dbP
dbBlock <- runNoLoggingT $ getMaxBlock pool
let sb = max dbBlock b
if sb > zgb_blocks bStatus || sb < 1
then do
BT.modify $ set msg "Invalid starting block for scan"
BT.modify $ set displayBox MsgDisplay
liftIO $ BC.writeBChan eChan $ TickMsg "Invalid starting block for scan"
else do
let bList = [(sb + 1) .. (zgb_blocks bStatus)]
let step = (1.0 :: Float) / fromIntegral (zgb_blocks bStatus - (sb + 1))
mapM_ (processBlock step) bList
mapM_ (processBlock pool step) bList
where
processBlock :: Float -> Int -> BT.EventM Name State ()
processBlock step bl = do
s <- BT.get
processBlock :: ConnectionPool -> Float -> Int -> IO ()
processBlock pool step bl = do
r <-
liftIO $
makeZebraCall
(s ^. zebraHost)
(s ^. zebraPort)
zHost
zPort
"getblock"
[Data.Aeson.String $ T.pack $ show bl, jsonNumber 1]
case r of
Left e1 -> do
BT.modify $ set msg e1
BT.modify $ set displayBox MsgDisplay
liftIO $ BC.writeBChan eChan $ TickMsg e1
Right blk -> do
r2 <-
liftIO $
makeZebraCall
(s ^. zebraHost)
(s ^. zebraPort)
zHost
zPort
"getblock"
[Data.Aeson.String $ T.pack $ show bl, jsonNumber 0]
case r2 of
Left e2 -> do
BT.modify $ set msg e2
BT.modify $ set displayBox MsgDisplay
liftIO $ BC.writeBChan eChan $ TickMsg e2
Right hb -> do
let blockTime = getBlockTime hb
liftIO $
mapM_
(processTx
(s ^. zebraHost)
(s ^. zebraPort)
blockTime
(s ^. dbPath)) $
mapM_ (runNoLoggingT . processTx zHost zPort blockTime pool) $
bl_txs $ addTime blk blockTime
BT.modify $ set barValue $ validBarValue (s ^. barValue + step)
BT.modify $ set displayBox SyncDisplay
liftIO $ BC.writeBChan eChan $ TickVal step
addTime :: BlockResponse -> Int -> BlockResponse
addTime bl t =
BlockResponse
@ -544,14 +556,69 @@ scanZebra b = do
(bl_txs bl)
appEvent :: BT.BrickEvent Name Tick -> BT.EventM Name State ()
appEvent (BT.AppEvent Tick) = do
appEvent (BT.AppEvent t) = do
s <- BT.get
pool <- liftIO $ runNoLoggingT $ initPool $ s ^. dbPath
case t of
TickMsg m -> do
BT.modify $ set msg m
BT.modify $ set displayBox MsgDisplay
TickVal v -> do
case s ^. displayBox of
AddrDisplay -> return ()
MsgDisplay -> return ()
PhraseDisplay -> return ()
TxDisplay -> return ()
SyncDisplay -> do
if s ^. barValue == 1.0
then BT.modify $ set displayBox BlankDisplay
else BT.modify $ set displayBox SyncDisplay
_ -> return ()
then do
selWallet <-
do case L.listSelectedElement $ s ^. wallets of
Nothing -> do
let fWall =
L.listSelectedElement $
L.listMoveToBeginning $ s ^. wallets
case fWall of
Nothing -> throw $ userError "Failed to select wallet"
Just (_j, w1) -> return w1
Just (_k, w) -> return w
_ <-
liftIO $
syncWallet
(Config (s ^. dbPath) (s ^. zebraHost) (s ^. zebraPort))
selWallet
BT.modify $ set displayBox BlankDisplay
BT.modify $ set barValue 0.0
updatedState <- BT.get
ns <- liftIO $ refreshWallet updatedState
BT.put ns
else BT.modify $ set barValue $ validBarValue (v + s ^. barValue)
BlankDisplay -> do
case s ^. dialogBox of
AName -> return ()
AdName -> return ()
WName -> return ()
WSelect -> return ()
ASelect -> return ()
Blank -> do
if s ^. timer == 90
then do
BT.modify $ set barValue 0.0
BT.modify $ set displayBox SyncDisplay
sBlock <- liftIO $ getMinBirthdayHeight pool
_ <-
liftIO $
forkIO $
scanZebra
(s ^. dbPath)
(s ^. zebraHost)
(s ^. zebraPort)
sBlock
(s ^. eventDispatch)
BT.modify $ set timer 0
return ()
else do
BT.modify $ set timer $ 1 + s ^. timer
appEvent (BT.VtyEvent e) = do
r <- F.focusGetCurrent <$> use focusRing
s <- BT.get
@ -565,33 +632,47 @@ appEvent (BT.VtyEvent e) = do
_ev -> return ()
else do
case s ^. displayBox of
AddrDisplay -> BT.modify $ set displayBox BlankDisplay
AddrDisplay -> do
case e of
V.EvKey (V.KChar 'x') [] ->
BT.modify $ set displayBox BlankDisplay
V.EvKey (V.KChar 'u') [] -> do
case L.listSelectedElement $ s ^. addresses of
Just (_, a) -> do
liftIO $
setClipboard $
T.unpack $
getUA $ walletAddressUAddress $ entityVal a
Nothing -> return ()
V.EvKey (V.KChar 's') [] -> do
case L.listSelectedElement $ s ^. addresses of
Just (_, a) -> do
liftIO $
setClipboard $
maybe "None" T.unpack $
getSaplingFromUA $
E.encodeUtf8 $
getUA $ walletAddressUAddress $ entityVal a
Nothing -> return ()
V.EvKey (V.KChar 't') [] -> do
case L.listSelectedElement $ s ^. addresses of
Just (_, a) -> do
liftIO $
setClipboard $
T.unpack $
maybe
"None"
(encodeTransparentReceiver (s ^. network)) $
t_rec =<<
(isValidUnifiedAddress .
E.encodeUtf8 . getUA . walletAddressUAddress)
(entityVal a)
Nothing -> return ()
_ev -> return ()
MsgDisplay -> BT.modify $ set displayBox BlankDisplay
PhraseDisplay -> BT.modify $ set displayBox BlankDisplay
TxDisplay -> BT.modify $ set displayBox BlankDisplay
SyncDisplay -> do
if s ^. barValue == 1.0
then BT.modify $ set displayBox BlankDisplay
else do
sBlock <- liftIO $ getMinBirthdayHeight $ s ^. dbPath
selWallet <-
do case L.listSelectedElement $ s ^. wallets of
Nothing -> do
let fWall =
L.listSelectedElement $
L.listMoveToBeginning $ s ^. wallets
case fWall of
Nothing ->
throw $ userError "Failed to select wallet"
Just (_j, w1) -> return w1
Just (_k, w) -> return w
scanZebra sBlock
liftIO $
runFileLoggingT "zenith.log" $
syncWallet
(Config (s ^. dbPath) (s ^. zebraHost) (s ^. zebraPort))
selWallet
BT.modify $ set displayBox SyncDisplay
SyncDisplay -> BT.modify $ set displayBox BlankDisplay
BlankDisplay -> do
case s ^. dialogBox of
WName -> do
@ -693,9 +774,6 @@ appEvent (BT.VtyEvent e) = do
BT.modify $ set displayBox TxDisplay
V.EvKey (V.KChar 'a') [] ->
BT.modify $ set dialogBox ASelect
V.EvKey (V.KChar 's') [] -> do
BT.modify $ set barValue 0.0
BT.modify $ set displayBox SyncDisplay
ev ->
case r of
Just AList ->
@ -740,6 +818,7 @@ runZenithCLI config = do
let host = c_zebraHost config
let port = c_zebraPort config
let dbFilePath = c_dbPath config
pool <- runNoLoggingT $ initPool dbFilePath
w <- try $ checkZebra host port :: IO (Either IOError ZebraGetInfo)
case w of
Right zebra -> do
@ -750,18 +829,18 @@ runZenithCLI config = do
Left e1 -> throwIO e1
Right chainInfo -> do
initDb dbFilePath
walList <- getWallets dbFilePath $ zgb_net chainInfo
walList <- getWallets pool $ zgb_net chainInfo
accList <-
if not (null walList)
then getAccounts dbFilePath $ entityKey $ head walList
then runNoLoggingT $ getAccounts pool $ entityKey $ head walList
else return []
addrList <-
if not (null accList)
then getAddresses dbFilePath $ entityKey $ head accList
then runNoLoggingT $ getAddresses pool $ entityKey $ head accList
else return []
txList <-
if not (null addrList)
then getUserTx dbFilePath $ entityKey $ head addrList
then getUserTx pool $ entityKey $ head addrList
else return []
let block =
if not (null walList)
@ -769,9 +848,14 @@ runZenithCLI config = do
else 0
bal <-
if not (null accList)
then getBalance dbFilePath $ entityKey $ head accList
then getBalance pool $ entityKey $ head accList
else return 0
eventChan <- BC.newBChan 10
_ <-
forkIO $
forever $ do
BC.writeBChan eventChan (TickVal 0.0)
threadDelay 1000000
let buildVty = VC.mkVty V.defaultConfig
initialVty <- buildVty
void $
@ -800,6 +884,7 @@ runZenithCLI config = do
bal
1.0
eventChan
0
Left e -> do
print $
"No Zebra node available on port " <>
@ -807,34 +892,38 @@ runZenithCLI config = do
refreshWallet :: State -> IO State
refreshWallet s = do
selWallet <-
pool <- runNoLoggingT $ initPool $ s ^. dbPath
walList <- getWallets pool $ s ^. network
(ix, selWallet) <-
do case L.listSelectedElement $ s ^. wallets of
Nothing -> do
let fWall =
L.listSelectedElement $ L.listMoveToBeginning $ s ^. wallets
case fWall of
Nothing -> throw $ userError "Failed to select wallet"
Just (_j, w1) -> return w1
Just (_k, w) -> return w
aL <- getAccounts (s ^. dbPath) $ entityKey selWallet
Just (j, w1) -> return (j, w1)
Just (k, w) -> return (k, w)
aL <- runNoLoggingT $ getAccounts pool $ entityKey selWallet
let bl = zcashWalletLastSync $ entityVal selWallet
addrL <-
if not (null aL)
then getAddresses (s ^. dbPath) $ entityKey $ head aL
then runNoLoggingT $ getAddresses pool $ entityKey $ head aL
else return []
bal <-
if not (null aL)
then getBalance (s ^. dbPath) $ entityKey $ head aL
then getBalance pool $ entityKey $ head aL
else return 0
txL <-
if not (null addrL)
then getUserTx (s ^. dbPath) $ entityKey $ head addrL
then getUserTx pool $ entityKey $ head addrL
else return []
let wL = L.listReplace (Vec.fromList walList) (Just ix) (s ^. wallets)
let aL' = L.listReplace (Vec.fromList aL) (Just 0) (s ^. accounts)
let addrL' = L.listReplace (Vec.fromList addrL) (Just 0) (s ^. addresses)
let txL' = L.listReplace (Vec.fromList txL) (Just 0) (s ^. transactions)
return $
(s & accounts .~ aL') & syncBlock .~ bl & balance .~ bal & addresses .~
s & wallets .~ wL & accounts .~ aL' & syncBlock .~ bl & balance .~ bal &
addresses .~
addrL' &
transactions .~
txL' &
@ -845,16 +934,15 @@ refreshWallet s = do
addNewWallet :: T.Text -> State -> IO State
addNewWallet n s = do
sP <- generateWalletSeedPhrase
pool <- runNoLoggingT $ initPool $ s ^. dbPath
let bH = s ^. startBlock
let netName = s ^. network
r <-
saveWallet (s ^. dbPath) $
ZcashWallet n (ZcashNetDB netName) (PhraseDB sP) bH 0
r <- saveWallet pool $ ZcashWallet n (ZcashNetDB netName) (PhraseDB sP) bH 0
case r of
Nothing -> do
return $ s & msg .~ ("Wallet already exists: " ++ T.unpack n)
Just _ -> do
wL <- getWallets (s ^. dbPath) netName
wL <- getWallets pool netName
let aL =
L.listFindBy (\x -> zcashWalletName (entityVal x) == n) $
L.listReplace (Vec.fromList wL) (Just 0) (s ^. wallets)
@ -862,6 +950,7 @@ addNewWallet n s = do
addNewAccount :: T.Text -> State -> IO State
addNewAccount n s = do
pool <- runNoLoggingT $ initPool $ s ^. dbPath
selWallet <-
do case L.listSelectedElement $ s ^. wallets of
Nothing -> do
@ -871,19 +960,19 @@ addNewAccount n s = do
Nothing -> throw $ userError "Failed to select wallet"
Just (_j, w1) -> return w1
Just (_k, w) -> return w
aL' <- getMaxAccount (s ^. dbPath) (entityKey selWallet)
aL' <- getMaxAccount pool (entityKey selWallet)
zA <-
try $ createZcashAccount n (aL' + 1) selWallet :: IO
(Either IOError ZcashAccount)
case zA of
Left e -> return $ s & msg .~ ("Error: " ++ show e)
Right zA' -> do
r <- saveAccount (s ^. dbPath) zA'
r <- saveAccount pool zA'
case r of
Nothing ->
return $ s & msg .~ ("Account already exists: " ++ T.unpack n)
Just x -> do
aL <- getAccounts (s ^. dbPath) (entityKey selWallet)
aL <- runNoLoggingT $ getAccounts pool (entityKey selWallet)
let nL =
L.listMoveToElement x $
L.listReplace (Vec.fromList aL) (Just 0) (s ^. accounts)
@ -892,6 +981,7 @@ addNewAccount n s = do
refreshAccount :: State -> IO State
refreshAccount s = do
pool <- runNoLoggingT $ initPool $ s ^. dbPath
selAccount <-
do case L.listSelectedElement $ s ^. accounts of
Nothing -> do
@ -901,8 +991,8 @@ refreshAccount s = do
Nothing -> throw $ userError "Failed to select account"
Just (_j, w1) -> return w1
Just (_k, w) -> return w
aL <- getAddresses (s ^. dbPath) $ entityKey selAccount
bal <- getBalance (s ^. dbPath) $ entityKey selAccount
aL <- runNoLoggingT $ getAddresses pool $ entityKey selAccount
bal <- getBalance pool $ entityKey selAccount
let aL' = L.listReplace (Vec.fromList aL) (Just 0) (s ^. addresses)
selAddress <-
do case L.listSelectedElement aL' of
@ -916,7 +1006,7 @@ refreshAccount s = do
s & balance .~ bal & addresses .~ aL' & msg .~ "Switched to account: " ++
T.unpack (zcashAccountName $ entityVal selAccount)
Just (_i, a) -> do
tList <- getUserTx (s ^. dbPath) $ entityKey a
tList <- getUserTx pool $ entityKey a
let tL' = L.listReplace (Vec.fromList tList) (Just 0) (s ^. transactions)
return $
s & balance .~ bal & addresses .~ aL' & transactions .~ tL' & msg .~
@ -925,6 +1015,7 @@ refreshAccount s = do
refreshTxs :: State -> IO State
refreshTxs s = do
pool <- runNoLoggingT $ initPool $ s ^. dbPath
selAddress <-
do case L.listSelectedElement $ s ^. addresses of
Nothing -> do
@ -935,12 +1026,13 @@ refreshTxs s = do
case selAddress of
Nothing -> return s
Just (_i, a) -> do
tList <- getUserTx (s ^. dbPath) $ entityKey a
tList <- getUserTx pool $ entityKey a
let tL' = L.listReplace (Vec.fromList tList) (Just 0) (s ^. transactions)
return $ s & transactions .~ tL'
addNewAddress :: T.Text -> Scope -> State -> IO State
addNewAddress n scope s = do
pool <- runNoLoggingT $ initPool $ s ^. dbPath
selAccount <-
do case L.listSelectedElement $ s ^. accounts of
Nothing -> do
@ -950,19 +1042,19 @@ addNewAddress n scope s = do
Nothing -> throw $ userError "Failed to select account"
Just (_j, a1) -> return a1
Just (_k, a) -> return a
maxAddr <- getMaxAddress (s ^. dbPath) (entityKey selAccount) scope
maxAddr <- getMaxAddress pool (entityKey selAccount) scope
uA <-
try $ createWalletAddress n (maxAddr + 1) (s ^. network) scope selAccount :: IO
(Either IOError WalletAddress)
case uA of
Left e -> return $ s & msg .~ ("Error: " ++ show e)
Right uA' -> do
nAddr <- saveAddress (s ^. dbPath) uA'
nAddr <- saveAddress pool uA'
case nAddr of
Nothing ->
return $ s & msg .~ ("Address already exists: " ++ T.unpack n)
Just x -> do
addrL <- getAddresses (s ^. dbPath) (entityKey selAccount)
addrL <- runNoLoggingT $ getAddresses pool (entityKey selAccount)
let nL =
L.listMoveToElement x $
L.listReplace (Vec.fromList addrL) (Just 0) (s ^. addresses)

224
src/Zenith/Core.hs
View file

@ -9,9 +9,11 @@ import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger
( LoggingT
, MonadLoggerIO
, NoLoggingT
, logInfoN
, logWarnN
, runFileLoggingT
, runNoLoggingT
, runStdoutLoggingT
)
import Crypto.Secp256k1 (SecKey(..))
@ -31,6 +33,7 @@ import Database.Persist
import Database.Persist.Sqlite
import GHC.Float.RealFracMethods (floorFloatInteger)
import Haskoin.Crypto.Keys (XPrvKey(..))
import Lens.Micro ((&), (.~), (^.), set)
import Network.HTTP.Client
import ZcashHaskell.Keys
import ZcashHaskell.Orchard
@ -230,22 +233,24 @@ findSaplingOutputs config b znet za = do
let zebraHost = c_zebraHost config
let zebraPort = c_zebraPort config
let zn = getNet znet
tList <- getShieldedOutputs dbPath b
pool <- runNoLoggingT $ initPool dbPath
tList <- getShieldedOutputs pool b
trees <- getCommitmentTrees zebraHost zebraPort (b - 1)
let sT = SaplingCommitmentTree $ ztiSapling trees
decryptNotes sT zn tList
sapNotes <- getWalletSapNotes dbPath (entityKey za)
findSapSpends dbPath (entityKey za) sapNotes
decryptNotes sT zn pool tList
sapNotes <- getWalletSapNotes pool (entityKey za)
findSapSpends pool (entityKey za) sapNotes
where
sk :: SaplingSpendingKeyDB
sk = zcashAccountSapSpendKey $ entityVal za
decryptNotes ::
SaplingCommitmentTree
-> ZcashNet
-> ConnectionPool
-> [(Entity ZcashTransaction, Entity ShieldOutput)]
-> IO ()
decryptNotes _ _ [] = return ()
decryptNotes st n ((zt, o):txs) = do
decryptNotes _ _ _ [] = return ()
decryptNotes st n pool ((zt, o):txs) = do
let updatedTree =
updateSaplingCommitmentTree
st
@ -262,15 +267,11 @@ findSaplingOutputs config b znet za = do
Nothing -> do
case decodeShOut Internal n nP o of
Nothing -> do
decryptNotes uT n txs
decryptNotes uT n pool txs
Just dn1 -> do
wId <-
saveWalletTransaction
(c_dbPath config)
(entityKey za)
zt
wId <- saveWalletTransaction pool (entityKey za) zt
saveWalletSapNote
(c_dbPath config)
pool
wId
nP
(fromJust noteWitness)
@ -278,12 +279,11 @@ findSaplingOutputs config b znet za = do
(entityKey za)
(entityKey o)
dn1
decryptNotes uT n txs
decryptNotes uT n pool txs
Just dn0 -> do
wId <-
saveWalletTransaction (c_dbPath config) (entityKey za) zt
wId <- saveWalletTransaction pool (entityKey za) zt
saveWalletSapNote
(c_dbPath config)
pool
wId
nP
(fromJust noteWitness)
@ -291,7 +291,7 @@ findSaplingOutputs config b znet za = do
(entityKey za)
(entityKey o)
dn0
decryptNotes uT n txs
decryptNotes uT n pool txs
decodeShOut ::
Scope
-> ZcashNet
@ -324,20 +324,22 @@ findOrchardActions config b znet za = do
let zebraHost = c_zebraHost config
let zebraPort = c_zebraPort config
let zn = getNet znet
tList <- getOrchardActions dbPath b
pool <- runNoLoggingT $ initPool dbPath
tList <- getOrchardActions pool b
trees <- getCommitmentTrees zebraHost zebraPort (b - 1)
let sT = OrchardCommitmentTree $ ztiOrchard trees
decryptNotes sT zn tList
orchNotes <- getWalletOrchNotes dbPath (entityKey za)
findOrchSpends dbPath (entityKey za) orchNotes
decryptNotes sT zn pool tList
orchNotes <- getWalletOrchNotes pool (entityKey za)
findOrchSpends pool (entityKey za) orchNotes
where
decryptNotes ::
OrchardCommitmentTree
-> ZcashNet
-> ConnectionPool
-> [(Entity ZcashTransaction, Entity OrchAction)]
-> IO ()
decryptNotes _ _ [] = return ()
decryptNotes ot n ((zt, o):txs) = do
decryptNotes _ _ _ [] = return ()
decryptNotes ot n pool ((zt, o):txs) = do
let updatedTree =
updateOrchardCommitmentTree
ot
@ -353,15 +355,11 @@ findOrchardActions config b znet za = do
case decodeOrchAction External nP o of
Nothing ->
case decodeOrchAction Internal nP o of
Nothing -> decryptNotes uT n txs
Nothing -> decryptNotes uT n pool txs
Just dn1 -> do
wId <-
saveWalletTransaction
(c_dbPath config)
(entityKey za)
zt
wId <- saveWalletTransaction pool (entityKey za) zt
saveWalletOrchNote
(c_dbPath config)
pool
wId
nP
(fromJust noteWitness)
@ -369,12 +367,11 @@ findOrchardActions config b znet za = do
(entityKey za)
(entityKey o)
dn1
decryptNotes uT n txs
decryptNotes uT n pool txs
Just dn -> do
wId <-
saveWalletTransaction (c_dbPath config) (entityKey za) zt
wId <- saveWalletTransaction pool (entityKey za) zt
saveWalletOrchNote
(c_dbPath config)
pool
wId
nP
(fromJust noteWitness)
@ -382,7 +379,7 @@ findOrchardActions config b znet za = do
(entityKey za)
(entityKey o)
dn
decryptNotes uT n txs
decryptNotes uT n pool txs
sk :: OrchardSpendingKeyDB
sk = zcashAccountOrchSpendKey $ entityVal za
decodeOrchAction ::
@ -399,48 +396,34 @@ findOrchardActions config b znet za = do
(getHex $ orchActionCv $ entityVal o)
(getHex $ orchActionAuth $ entityVal o)
updateSaplingWitnesses :: T.Text -> LoggingT IO ()
updateSaplingWitnesses dbPath = do
sapNotes <- liftIO $ getUnspentSapNotes dbPath
pool <- createSqlitePool dbPath 5
updateSaplingWitnesses :: ConnectionPool -> IO ()
updateSaplingWitnesses pool = do
sapNotes <- getUnspentSapNotes pool
maxId <- liftIO $ getMaxSaplingNote pool
mapM_ (updateOneNote pool maxId) sapNotes
mapM_ (updateOneNote maxId) sapNotes
where
updateOneNote ::
Pool SqlBackend
-> ShieldOutputId
-> Entity WalletSapNote
-> LoggingT IO ()
updateOneNote pool maxId n = do
updateOneNote :: ShieldOutputId -> Entity WalletSapNote -> IO ()
updateOneNote maxId n = do
let noteSync = walletSapNoteWitPos $ entityVal n
if noteSync < maxId
then do
cmus <-
liftIO $ getSaplingCmus pool $ walletSapNoteWitPos $ entityVal n
when (noteSync < maxId) $ do
cmus <- liftIO $ getSaplingCmus pool $ walletSapNoteWitPos $ entityVal n
let cmuList = map (\(ESQ.Value x) -> getHex x) cmus
let newWitness =
updateSaplingWitness
(SaplingWitness $ getHex $ walletSapNoteWitness $ entityVal n)
cmuList
liftIO $ updateSapNoteRecord pool (entityKey n) newWitness maxId
else logInfoN "Witness up to date"
updateOrchardWitnesses :: T.Text -> LoggingT IO ()
updateOrchardWitnesses dbPath = do
orchNotes <- liftIO $ getUnspentOrchNotes dbPath
pool <- createSqlitePool dbPath 5
maxId <- liftIO $ getMaxOrchardNote pool
mapM_ (updateOneNote pool maxId) orchNotes
updateOrchardWitnesses :: ConnectionPool -> IO ()
updateOrchardWitnesses pool = do
orchNotes <- getUnspentOrchNotes pool
maxId <- getMaxOrchardNote pool
mapM_ (updateOneNote maxId) orchNotes
where
updateOneNote ::
Pool SqlBackend
-> OrchActionId
-> Entity WalletOrchNote
-> LoggingT IO ()
updateOneNote pool maxId n = do
updateOneNote :: OrchActionId -> Entity WalletOrchNote -> IO ()
updateOneNote maxId n = do
let noteSync = walletOrchNoteWitPos $ entityVal n
if noteSync < maxId
then do
when (noteSync < maxId) $ do
cmxs <- liftIO $ getOrchardCmxs pool noteSync
let cmxList = map (\(ESQ.Value x) -> getHex x) cmxs
let newWitness =
@ -448,7 +431,6 @@ updateOrchardWitnesses dbPath = do
(OrchardWitness $ getHex $ walletOrchNoteWitness $ entityVal n)
cmxList
liftIO $ updateOrchNoteRecord pool (entityKey n) newWitness maxId
else logInfoN "Witness up to date"
-- | Calculate fee per ZIP-317
calculateTxFee ::
@ -474,7 +456,7 @@ calculateTxFee (t, s, o) i =
-- | Prepare a transaction for sending
prepareTx ::
T.Text
ConnectionPool
-> T.Text
-> Int
-> ZcashNet
@ -484,8 +466,8 @@ prepareTx ::
-> UnifiedAddress
-> T.Text
-> IO (Either TxError HexString)
prepareTx dbPath zebraHost zebraPort zn za bh amt ua memo = do
accRead <- getAccountById dbPath za
prepareTx pool zebraHost zebraPort zn za bh amt ua memo = do
accRead <- getAccountById pool za
let recipient =
case o_rec ua of
Nothing ->
@ -521,11 +503,11 @@ prepareTx dbPath zebraHost zebraPort zn za bh amt ua memo = do
print $ BS.length outParams
print "Read Sapling params"
let zats = fromIntegral $ floorFloatInteger $ amt * (10 ^ 8)
firstPass <- selectUnspentNotes dbPath za zats
firstPass <- selectUnspentNotes pool za zats
let fee = calculateTxFee firstPass 3
print "calculated fee"
print fee
(tList, sList, oList) <- selectUnspentNotes dbPath za (zats + fee)
(tList, sList, oList) <- selectUnspentNotes pool za (zats + fee)
print "selected notes"
print tList
print sList
@ -564,7 +546,7 @@ prepareTx dbPath zebraHost zebraPort zn za bh amt ua memo = do
-> Integer
-> IO [OutgoingNote]
makeOutgoing acc (k, recvr) zats chg = do
chgAddr <- getInternalAddresses dbPath $ entityKey acc
chgAddr <- runNoLoggingT $ getInternalAddresses pool $ entityKey acc
let internalUA = getUA $ walletAddressUAddress $ entityVal $ head chgAddr
let chgRcvr =
fromJust $ o_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA)
@ -604,7 +586,7 @@ prepareTx dbPath zebraHost zebraPort zn za bh amt ua memo = do
-> IO [TransparentTxSpend]
prepTSpends sk notes = do
forM notes $ \n -> do
tAddRead <- getAddressById dbPath $ walletTrNoteAddress $ entityVal n
tAddRead <- getAddressById pool $ walletTrNoteAddress $ entityVal n
print n
case tAddRead of
Nothing -> throwIO $ userError "Couldn't read t-address"
@ -614,7 +596,7 @@ prepareTx dbPath zebraHost zebraPort zn za bh amt ua memo = do
(walletAddressIndex $ entityVal tAdd)
(getScope $ walletAddressScope $ entityVal tAdd)
sk
mReverseTxId <- getWalletTxId dbPath $ walletTrNoteTx $ entityVal n
mReverseTxId <- getWalletTxId pool $ walletTrNoteTx $ entityVal n
case mReverseTxId of
Nothing -> throwIO $ userError "failed to get tx ID"
Just (ESQ.Value reverseTxId) -> do
@ -679,22 +661,24 @@ prepareTx dbPath zebraHost zebraPort zn za bh amt ua memo = do
syncWallet ::
Config -- ^ configuration parameters
-> Entity ZcashWallet
-> LoggingT IO ()
-> IO ()
syncWallet config w = do
startTime <- liftIO getCurrentTime
let walletDb = c_dbPath config
accs <- liftIO $ getAccounts walletDb $ entityKey w
addrs <- liftIO $ concat <$> mapM (getAddresses walletDb . entityKey) accs
pool <- runNoLoggingT $ initPool walletDb
accs <- runNoLoggingT $ getAccounts pool $ entityKey w
addrs <- concat <$> mapM (runNoLoggingT . getAddresses pool . entityKey) accs
intAddrs <-
liftIO $ concat <$> mapM (getInternalAddresses walletDb . entityKey) accs
chainTip <- liftIO $ getMaxBlock walletDb
concat <$> mapM (runNoLoggingT . getInternalAddresses pool . entityKey) accs
chainTip <- runNoLoggingT $ getMaxBlock pool
let lastBlock = zcashWalletLastSync $ entityVal w
let startBlock =
if lastBlock > 0
then lastBlock
else zcashWalletBirthdayHeight $ entityVal w
mapM_ (liftIO . findTransparentNotes walletDb startBlock) addrs
mapM_ (liftIO . findTransparentNotes walletDb startBlock) intAddrs
mapM_ (liftIO . findTransparentSpends walletDb . entityKey) accs
mapM_ (liftIO . findTransparentNotes pool startBlock) addrs
mapM_ (liftIO . findTransparentNotes pool startBlock) intAddrs
mapM_ (liftIO . findTransparentSpends pool . entityKey) accs
sapNotes <-
liftIO $
mapM
@ -705,52 +689,52 @@ syncWallet config w = do
mapM
(findOrchardActions config startBlock (zcashWalletNetwork $ entityVal w))
accs
_ <- updateSaplingWitnesses walletDb
_ <- updateOrchardWitnesses walletDb
_ <- liftIO $ updateWalletSync walletDb chainTip (entityKey w)
_ <- liftIO $ mapM_ (getWalletTransactions walletDb) addrs
logInfoN "Synced wallet"
_ <- updateSaplingWitnesses pool
_ <- updateOrchardWitnesses pool
_ <- liftIO $ updateWalletSync pool chainTip (entityKey w)
mapM_ (runNoLoggingT . getWalletTransactions pool) addrs
testSync :: Config -> IO ()
testSync config = do
let dbPath = c_dbPath config
_ <- initDb dbPath
w <- getWallets dbPath TestNet
r <- runFileLoggingT "zenith.log" $ mapM (syncWallet config) w
pool <- runNoLoggingT $ initPool dbPath
w <- getWallets pool TestNet
r <- mapM (syncWallet config) w
liftIO $ print r
{-let uaRead =-}
{-isValidUnifiedAddress-}
{-"utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax"-}
{-case uaRead of-}
{-Nothing -> print "wrong address"-}
{-Just ua -> do-}
{-startTime <- getCurrentTime-}
{-print startTime-}
{-tx <--}
{-prepareTx-}
{-"zenith.db"-}
{-"127.0.0.1"-}
{-18232-}
{-TestNet-}
{-(toSqlKey 1)-}
{-2820897-}
{-0.04-}
{-ua-}
{-"sent with Zenith, test"-}
{-print tx-}
{-endTime <- getCurrentTime-}
{-print endTime-}
testSend :: IO ()
testSend = do
let uaRead =
isValidUnifiedAddress
"utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax"
case uaRead of
Nothing -> print "wrong address"
Just ua -> do
startTime <- getCurrentTime
print startTime
tx <-
prepareTx
"zenith.db"
"127.0.0.1"
18232
TestNet
(toSqlKey 1)
2820897
0.04
ua
"sent with Zenith, test"
print tx
endTime <- getCurrentTime
print endTime
{-testSend :: IO ()-}
{-testSend = do-}
clearSync :: Config -> IO ()
clearSync config = do
let dbPath = c_dbPath config
pool <- runNoLoggingT $ initPool dbPath
_ <- initDb dbPath
_ <- clearWalletTransactions dbPath
w <- getWallets dbPath TestNet
liftIO $ mapM_ (updateWalletSync dbPath 0 . entityKey) w
w' <- liftIO $ getWallets dbPath TestNet
r <- runFileLoggingT "zenith.log" $ mapM (syncWallet config) w'
_ <- clearWalletTransactions pool
w <- getWallets pool TestNet
liftIO $ mapM_ (updateWalletSync pool 0 . entityKey) w
w' <- liftIO $ getWallets pool TestNet
r <- mapM (syncWallet config) w'
liftIO $ print r

462
src/Zenith/DB.hs
View file

@ -21,6 +21,7 @@ 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
@ -40,6 +41,7 @@ import Haskoin.Transaction.Common
, TxOut(..)
, txHashToHex
)
import qualified Lens.Micro as ML ((&), (.~), (^.))
import ZcashHaskell.Orchard (isValidUnifiedAddress)
import ZcashHaskell.Sapling (decodeSaplingOutputEsk)
import ZcashHaskell.Types
@ -251,6 +253,11 @@ initDb ::
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
@ -259,9 +266,11 @@ upgradeDb dbName = do
PS.runSqlite dbName $ do runMigrationUnsafe migrateAll
-- | Get existing wallets from database
getWallets :: T.Text -> ZcashNet -> IO [Entity ZcashWallet]
getWallets dbFp n =
PS.runSqlite dbFp $
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))
@ -269,34 +278,42 @@ getWallets dbFp n =
-- | Save a new wallet to the database
saveWallet ::
T.Text -- ^ The database path to use
ConnectionPool -- ^ The database path to use
-> ZcashWallet -- ^ The wallet to add to the database
-> IO (Maybe (Entity ZcashWallet))
saveWallet dbFp w = PS.runSqlite dbFp $ insertUniqueEntity w
saveWallet pool w =
runNoLoggingT $
PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUniqueEntity w
-- | Update the last sync block for the wallet
updateWalletSync :: T.Text -> Int -> ZcashWalletId -> IO ()
updateWalletSync dbPath b i = do
PS.runSqlite dbPath $ do
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 ::
T.Text -- ^ The database path
ConnectionPool -- ^ The database path
-> ZcashWalletId -- ^ The wallet ID to check
-> IO [Entity ZcashAccount]
getAccounts dbFp w =
PS.runSqlite dbFp $
-> 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 :: T.Text -> ZcashAccountId -> IO (Maybe (Entity ZcashAccount))
getAccountById dbPath za = do
PS.runSqlite dbPath $
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)
@ -304,12 +321,14 @@ getAccountById dbPath za = do
-- | Returns the largest account index for the given wallet
getMaxAccount ::
T.Text -- ^ The database path
ConnectionPool -- ^ The database path
-> ZcashWalletId -- ^ The wallet ID to check
-> IO Int
getMaxAccount dbFp w = do
getMaxAccount pool w = do
a <-
PS.runSqlite dbFp $
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
selectOne $ do
accs <- from $ table @ZcashAccount
where_ (accs ^. ZcashAccountWalletId ==. val w)
@ -321,18 +340,21 @@ getMaxAccount dbFp w = do
-- | Save a new account to the database
saveAccount ::
T.Text -- ^ The database path
ConnectionPool -- ^ The database path
-> ZcashAccount -- ^ The account to add to the database
-> IO (Maybe (Entity ZcashAccount))
saveAccount dbFp a = PS.runSqlite dbFp $ insertUniqueEntity a
saveAccount pool a =
runNoLoggingT $
PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUniqueEntity a
-- | Returns the largest block in storage
getMaxBlock ::
T.Text -- ^ The database path
-> IO Int
getMaxBlock dbPath = do
Pool SqlBackend -- ^ The database pool
-> NoLoggingT IO Int
getMaxBlock pool = do
b <-
PS.runSqlite dbPath $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
selectOne $ do
txs <- from $ table @ZcashTransaction
where_ (txs ^. ZcashTransactionBlock >. val 0)
@ -344,20 +366,24 @@ getMaxBlock dbPath = do
-- | Returns a list of addresses associated with the given account
getAddresses ::
T.Text -- ^ The database path
ConnectionPool -- ^ The database path
-> ZcashAccountId -- ^ The account ID to check
-> IO [Entity WalletAddress]
getAddresses dbFp a =
PS.runSqlite dbFp $
-> 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 :: T.Text -> WalletAddressId -> IO (Maybe (Entity WalletAddress))
getAddressById dbPath a = do
PS.runSqlite dbPath $
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)
@ -365,11 +391,12 @@ getAddressById dbPath a = do
-- | Returns a list of change addresses associated with the given account
getInternalAddresses ::
T.Text -- ^ The database path
ConnectionPool -- ^ The database path
-> ZcashAccountId -- ^ The account ID to check
-> IO [Entity WalletAddress]
getInternalAddresses dbFp a =
PS.runSqlite dbFp $
-> 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)
@ -378,23 +405,25 @@ getInternalAddresses dbFp a =
-- | Returns a list of addressess associated with the given wallet
getWalletAddresses ::
T.Text -- ^ The database path
ConnectionPool -- ^ The database path
-> ZcashWalletId -- ^ the wallet to search
-> IO [Entity WalletAddress]
getWalletAddresses dbFp w = do
accs <- getAccounts dbFp w
addrs <- mapM (getAddresses dbFp . entityKey) accs
-> NoLoggingT IO [Entity WalletAddress]
getWalletAddresses pool w = do
accs <- getAccounts pool w
addrs <- mapM (getAddresses pool . entityKey) accs
return $ concat addrs
-- | Returns the largest address index for the given account
getMaxAddress ::
T.Text -- ^ The database path
ConnectionPool -- ^ The database path
-> ZcashAccountId -- ^ The account ID to check
-> Scope -- ^ The scope of the address
-> IO Int
getMaxAddress dbFp aw s = do
getMaxAddress pool aw s = do
a <-
PS.runSqlite dbFp $
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
selectOne $ do
addrs <- from $ table @WalletAddress
where_ $ addrs ^. WalletAddressAccId ==. val aw
@ -407,19 +436,22 @@ getMaxAddress dbFp aw s = do
-- | Save a new address to the database
saveAddress ::
T.Text -- ^ the database path
ConnectionPool -- ^ the database path
-> WalletAddress -- ^ The wallet to add to the database
-> IO (Maybe (Entity WalletAddress))
saveAddress dbFp w = PS.runSqlite dbFp $ insertUniqueEntity w
saveAddress pool w =
runNoLoggingT $
PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUniqueEntity w
-- | Save a transaction to the data model
saveTransaction ::
T.Text -- ^ the database path
ConnectionPool -- ^ the database path
-> Int -- ^ block time
-> Transaction -- ^ The transaction to save
-> IO (Key ZcashTransaction)
saveTransaction dbFp t wt =
PS.runSqlite dbFp $ do
-> NoLoggingT IO (Key ZcashTransaction)
saveTransaction pool t wt =
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
let ix = [0 ..]
w <-
insert $
@ -500,11 +532,13 @@ saveTransaction dbFp t wt =
-- | Get the transactions from a particular block forward
getZcashTransactions ::
T.Text -- ^ The database path
ConnectionPool -- ^ The database path
-> Int -- ^ Block
-> IO [Entity ZcashTransaction]
getZcashTransactions dbFp b =
PS.runSqlite dbFp $
getZcashTransactions pool b =
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
select $ do
txs <- from $ table @ZcashTransaction
where_ $ txs ^. ZcashTransactionBlock >. val b
@ -514,11 +548,13 @@ getZcashTransactions dbFp b =
-- * Wallet
-- | Get the block of the last transaction known to the wallet
getMaxWalletBlock ::
T.Text -- ^ The database path
ConnectionPool -- ^ The database path
-> IO Int
getMaxWalletBlock dbPath = do
getMaxWalletBlock pool = do
b <-
PS.runSqlite dbPath $
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
selectOne $ do
txs <- from $ table @WalletTransaction
where_ $ txs ^. WalletTransactionBlock >. val 0
@ -528,10 +564,12 @@ getMaxWalletBlock dbPath = do
Nothing -> return $ -1
Just x -> return $ walletTransactionBlock $ entityVal x
getMinBirthdayHeight :: T.Text -> IO Int
getMinBirthdayHeight dbPath = do
getMinBirthdayHeight :: ConnectionPool -> IO Int
getMinBirthdayHeight pool = do
b <-
PS.runSqlite dbPath $
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
selectOne $ do
w <- from $ table @ZcashWallet
where_ (w ^. ZcashWalletBirthdayHeight >. val 0)
@ -543,13 +581,15 @@ getMinBirthdayHeight dbPath = do
-- | Save a @WalletTransaction@
saveWalletTransaction ::
T.Text
ConnectionPool
-> ZcashAccountId
-> Entity ZcashTransaction
-> IO WalletTransactionId
saveWalletTransaction dbPath za zt = do
saveWalletTransaction pool za zt = do
let zT' = entityVal zt
PS.runSqlite dbPath $ do
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
t <-
upsert
(WalletTransaction
@ -563,7 +603,7 @@ saveWalletTransaction dbPath za zt = do
-- | Save a @WalletSapNote@
saveWalletSapNote ::
T.Text -- ^ The database path
ConnectionPool -- ^ The database path
-> WalletTransactionId -- ^ The index for the transaction that contains the note
-> Integer -- ^ note position
-> SaplingWitness -- ^ the Sapling incremental witness
@ -572,8 +612,10 @@ saveWalletSapNote ::
-> ShieldOutputId
-> DecodedNote -- The decoded Sapling note
-> IO ()
saveWalletSapNote dbPath wId pos wit ch za zt dn = do
PS.runSqlite dbPath $ do
saveWalletSapNote pool wId pos wit ch za zt dn = do
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
_ <-
upsert
(WalletSapNote
@ -594,7 +636,7 @@ saveWalletSapNote dbPath wId pos wit ch za zt dn = do
-- | Save a @WalletOrchNote@
saveWalletOrchNote ::
T.Text
ConnectionPool
-> WalletTransactionId
-> Integer
-> OrchardWitness
@ -603,8 +645,10 @@ saveWalletOrchNote ::
-> OrchActionId
-> DecodedNote
-> IO ()
saveWalletOrchNote dbPath wId pos wit ch za zt dn = do
PS.runSqlite dbPath $ do
saveWalletOrchNote pool wId pos wit ch za zt dn = do
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
_ <-
upsert
(WalletOrchNote
@ -626,11 +670,11 @@ saveWalletOrchNote dbPath wId pos wit ch za zt dn = do
-- | Find the Transparent Notes that match the given transparent receiver
findTransparentNotes ::
T.Text -- ^ The database path
ConnectionPool -- ^ The database path
-> Int -- ^ Starting block
-> Entity WalletAddress
-> IO ()
findTransparentNotes dbPath b t = do
findTransparentNotes pool b t = do
let tReceiver = t_rec =<< readUnifiedAddressDB (entityVal t)
case tReceiver of
Just tR -> do
@ -641,7 +685,9 @@ findTransparentNotes dbPath b t = do
, BS.pack [0x88, 0xAC]
]
tN <-
PS.runSqlite dbPath $
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
select $ do
(txs :& tNotes) <-
from $ table @ZcashTransaction `innerJoin` table @TransparentNote `on`
@ -652,7 +698,7 @@ findTransparentNotes dbPath b t = do
pure (txs, tNotes)
mapM_
(saveWalletTrNote
dbPath
pool
(getScope $ walletAddressScope $ entityVal t)
(walletAddressAccId $ entityVal t)
(entityKey t))
@ -661,15 +707,17 @@ findTransparentNotes dbPath b t = do
-- | Add the transparent notes to the wallet
saveWalletTrNote ::
T.Text -- ^ the database path
ConnectionPool -- ^ the database path
-> Scope
-> ZcashAccountId
-> WalletAddressId
-> (Entity ZcashTransaction, Entity TransparentNote)
-> IO ()
saveWalletTrNote dbPath ch za wa (zt, tn) = do
saveWalletTrNote pool ch za wa (zt, tn) = do
let zT' = entityVal zt
PS.runSqlite dbPath $ do
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
t <-
upsert
(WalletTransaction
@ -691,16 +739,19 @@ saveWalletTrNote dbPath ch za wa (zt, tn) = do
(fromIntegral $ transparentNotePosition $ entityVal tn)
-- | Save a Sapling note to the wallet database
saveSapNote :: T.Text -> WalletSapNote -> IO ()
saveSapNote dbPath wsn = PS.runSqlite dbPath $ do insert_ wsn
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 ::
T.Text -- ^ database path
ConnectionPool -- ^ database path
-> Int -- ^ block
-> IO [(Entity ZcashTransaction, Entity ShieldOutput)]
getShieldedOutputs dbPath b =
PS.runSqlite dbPath $ do
getShieldedOutputs pool b =
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
select $ do
(txs :& sOutputs) <-
from $ table @ZcashTransaction `innerJoin` table @ShieldOutput `on`
@ -715,11 +766,13 @@ getShieldedOutputs dbPath b =
-- | Get the Orchard actions from the given blockheight forward
getOrchardActions ::
T.Text -- ^ database path
ConnectionPool -- ^ database path
-> Int -- ^ block
-> IO [(Entity ZcashTransaction, Entity OrchAction)]
getOrchardActions dbPath b =
PS.runSqlite dbPath $ do
getOrchardActions pool b =
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
select $ do
(txs :& oActions) <-
from $ table @ZcashTransaction `innerJoin` table @OrchAction `on`
@ -732,12 +785,12 @@ getOrchardActions dbPath b =
-- | Get the transactions belonging to the given address
getWalletTransactions ::
T.Text -- ^ database path
ConnectionPool -- ^ database path
-> Entity WalletAddress
-> IO ()
getWalletTransactions dbPath w = do
-> NoLoggingT IO ()
getWalletTransactions pool w = do
let w' = entityVal w
chgAddr <- getInternalAddresses dbPath $ walletAddressAccId $ 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)
@ -754,7 +807,8 @@ getWalletTransactions dbPath w = do
, (toBytes . tr_bytes) tR
, BS.pack [0x88, 0xAC]
]
PS.runSqlite dbPath $ do
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
select $ do
tnotes <- from $ table @WalletTrNote
where_ (tnotes ^. WalletTrNoteScript ==. val s)
@ -769,13 +823,15 @@ getWalletTransactions dbPath w = do
, (toBytes . tr_bytes) tR
, BS.pack [0x88, 0xAC]
]
PS.runSqlite dbPath $ do
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
select $ do
tnotes <- from $ table @WalletTrNote
where_ (tnotes ^. WalletTrNoteScript ==. val s1)
pure tnotes
trSpends <-
PS.runSqlite dbPath $ do
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
select $ do
trSpends <- from $ table @WalletTrSpend
where_
@ -786,7 +842,8 @@ getWalletTransactions dbPath w = do
case sReceiver of
Nothing -> return []
Just sR -> do
PS.runSqlite dbPath $ do
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
select $ do
snotes <- from $ table @WalletSapNote
where_ (snotes ^. WalletSapNoteRecipient ==. val (getBytes sR))
@ -795,7 +852,8 @@ getWalletTransactions dbPath w = do
case csReceiver of
Nothing -> return []
Just sR -> do
PS.runSqlite dbPath $ do
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
select $ do
snotes <- from $ table @WalletSapNote
where_ (snotes ^. WalletSapNoteRecipient ==. val (getBytes sR))
@ -805,7 +863,8 @@ getWalletTransactions dbPath w = do
case oReceiver of
Nothing -> return []
Just oR -> do
PS.runSqlite dbPath $ do
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
select $ do
onotes <- from $ table @WalletOrchNote
where_ (onotes ^. WalletOrchNoteRecipient ==. val (getBytes oR))
@ -814,12 +873,14 @@ getWalletTransactions dbPath w = do
case coReceiver of
Nothing -> return []
Just oR -> do
PS.runSqlite dbPath $ 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
@ -830,56 +891,68 @@ getWalletTransactions dbPath w = do
mapM_ subSSpend $ catMaybes sapSpends
mapM_ subOSpend $ catMaybes orchSpends
where
getSapSpends :: WalletSapNoteId -> IO (Maybe (Entity WalletSapSpend))
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.runSqlite dbPath $ do
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
selectOne $ do
sapSpends <- from $ table @WalletSapSpend
where_ (sapSpends ^. WalletSapSpendNote ==. val n)
pure sapSpends
getOrchSpends :: WalletOrchNoteId -> IO (Maybe (Entity WalletOrchSpend))
getOrchSpends ::
WalletOrchNoteId -> NoLoggingT IO (Maybe (Entity WalletOrchSpend))
getOrchSpends n = do
PS.runSqlite dbPath $ do
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
selectOne $ do
orchSpends <- from $ table @WalletOrchSpend
where_ (orchSpends ^. WalletOrchSpendNote ==. val n)
pure orchSpends
addTr :: Entity WalletTrNote -> IO ()
addTr :: Entity WalletTrNote -> NoLoggingT IO ()
addTr n =
upsertUserTx
(walletTrNoteTx $ entityVal n)
(entityKey w)
(fromIntegral $ walletTrNoteValue $ entityVal n)
""
addSap :: Entity WalletSapNote -> IO ()
addSap :: Entity WalletSapNote -> NoLoggingT IO ()
addSap n =
upsertUserTx
(walletSapNoteTx $ entityVal n)
(entityKey w)
(fromIntegral $ walletSapNoteValue $ entityVal n)
(walletSapNoteMemo $ entityVal n)
addOrch :: Entity WalletOrchNote -> IO ()
addOrch :: Entity WalletOrchNote -> NoLoggingT IO ()
addOrch n =
upsertUserTx
(walletOrchNoteTx $ entityVal n)
(entityKey w)
(fromIntegral $ walletOrchNoteValue $ entityVal n)
(walletOrchNoteMemo $ entityVal n)
subTSpend :: Entity WalletTrSpend -> IO ()
subTSpend :: Entity WalletTrSpend -> NoLoggingT IO ()
subTSpend n =
upsertUserTx
(walletTrSpendTx $ entityVal n)
(entityKey w)
(-(fromIntegral $ walletTrSpendValue $ entityVal n))
""
subSSpend :: Entity WalletSapSpend -> IO ()
subSSpend :: Entity WalletSapSpend -> NoLoggingT IO ()
subSSpend n =
upsertUserTx
(walletSapSpendTx $ entityVal n)
(entityKey w)
(-(fromIntegral $ walletSapSpendValue $ entityVal n))
""
subOSpend :: Entity WalletOrchSpend -> IO ()
subOSpend :: Entity WalletOrchSpend -> NoLoggingT IO ()
subOSpend n =
upsertUserTx
(walletOrchSpendTx $ entityVal n)
@ -887,16 +960,22 @@ getWalletTransactions dbPath w = do
(-(fromIntegral $ walletOrchSpendValue $ entityVal n))
""
upsertUserTx ::
WalletTransactionId -> WalletAddressId -> Int -> T.Text -> IO ()
WalletTransactionId
-> WalletAddressId
-> Int
-> T.Text
-> NoLoggingT IO ()
upsertUserTx tId wId amt memo = do
tr <-
PS.runSqlite dbPath $ do
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
select $ do
tx <- from $ table @WalletTransaction
where_ (tx ^. WalletTransactionId ==. val tId)
pure tx
existingUtx <-
PS.runSqlite dbPath $ do
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
selectOne $ do
ut <- from $ table @UserTx
where_
@ -907,7 +986,8 @@ getWalletTransactions dbPath w = do
case existingUtx of
Nothing -> do
_ <-
PS.runSqlite dbPath $ do
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
upsert
(UserTx
(walletTransactionTxId $ entityVal $ head tr)
@ -919,7 +999,8 @@ getWalletTransactions dbPath w = do
return ()
Just uTx -> do
_ <-
PS.runSqlite dbPath $ do
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
update $ \t -> do
set
t
@ -930,33 +1011,40 @@ getWalletTransactions dbPath w = do
where_ (t ^. UserTxId ==. val (entityKey uTx))
return ()
getUserTx :: T.Text -> WalletAddressId -> IO [Entity UserTx]
getUserTx dbPath aId = do
PS.runSqlite dbPath $ do
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 :: T.Text -> ZcashAccountId -> IO [Entity WalletTrNote]
getWalletTrNotes dbPath za = do
PS.runSqlite dbPath $ do
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 :: T.Text -> ZcashAccountId -> IO ()
findTransparentSpends dbPath za = do
notes <- getWalletTrNotes dbPath za
findTransparentSpends :: ConnectionPool -> ZcashAccountId -> IO ()
findTransparentSpends pool za = do
notes <- getWalletTrNotes pool za
mapM_ findOneTrSpend notes
where
findOneTrSpend :: Entity WalletTrNote -> IO ()
findOneTrSpend n = do
mReverseTxId <-
PS.runSqlite dbPath $ do
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
selectOne $ do
wtx <- from $ table @WalletTransaction
where_
@ -969,7 +1057,9 @@ findTransparentSpends dbPath za = do
HexStringDB $
HexString $ BS.reverse $ toBytes $ getHex reverseTxId
s <-
PS.runSqlite dbPath $ do
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
select $ do
(tx :& trSpends) <-
from $
@ -985,7 +1075,9 @@ findTransparentSpends dbPath za = do
if null s
then return ()
else do
PS.runSqlite dbPath $ do
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
_ <-
update $ \w -> do
set w [WalletTrNoteSpent =. val True]
@ -998,20 +1090,26 @@ findTransparentSpends dbPath za = do
za
(walletTrNoteValue $ entityVal n)
getWalletSapNotes :: T.Text -> ZcashAccountId -> IO [Entity WalletSapNote]
getWalletSapNotes dbPath za = do
PS.runSqlite dbPath $ do
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 :: T.Text -> ZcashAccountId -> [Entity WalletSapNote] -> IO ()
findSapSpends ::
ConnectionPool -> ZcashAccountId -> [Entity WalletSapNote] -> IO ()
findSapSpends _ _ [] = return ()
findSapSpends dbPath za (n:notes) = do
findSapSpends pool za (n:notes) = do
s <-
PS.runSqlite dbPath $ do
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
select $ do
(tx :& sapSpends) <-
from $ table @ZcashTransaction `innerJoin` table @ShieldSpend `on`
@ -1022,9 +1120,11 @@ findSapSpends dbPath za (n:notes) = do
val (walletSapNoteNullifier (entityVal n)))
pure (tx, sapSpends)
if null s
then findSapSpends dbPath za notes
then findSapSpends pool za notes
else do
PS.runSqlite dbPath $ do
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
_ <-
update $ \w -> do
set w [WalletSapNoteSpent =. val True]
@ -1036,19 +1136,24 @@ findSapSpends dbPath za (n:notes) = do
(entityKey n)
za
(walletSapNoteValue $ entityVal n)
findSapSpends dbPath za notes
findSapSpends pool za notes
getWalletOrchNotes :: T.Text -> ZcashAccountId -> IO [Entity WalletOrchNote]
getWalletOrchNotes dbPath za = do
PS.runSqlite dbPath $ do
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 :: T.Text -> IO [Entity WalletSapNote]
getUnspentSapNotes dbPath = do
PS.runSqlite dbPath $ do
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)
@ -1093,9 +1198,11 @@ updateSapNoteRecord pool n w o = do
]
where_ (x ^. WalletSapNoteId ==. val n)
getUnspentOrchNotes :: T.Text -> IO [Entity WalletOrchNote]
getUnspentOrchNotes dbPath = do
PS.runSqlite dbPath $ do
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)
@ -1140,11 +1247,14 @@ updateOrchNoteRecord pool n w o = do
]
where_ (x ^. WalletOrchNoteId ==. val n)
findOrchSpends :: T.Text -> ZcashAccountId -> [Entity WalletOrchNote] -> IO ()
findOrchSpends ::
ConnectionPool -> ZcashAccountId -> [Entity WalletOrchNote] -> IO ()
findOrchSpends _ _ [] = return ()
findOrchSpends dbPath za (n:notes) = do
findOrchSpends pool za (n:notes) = do
s <-
PS.runSqlite dbPath $ do
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
select $ do
(tx :& orchSpends) <-
from $ table @ZcashTransaction `innerJoin` table @OrchAction `on`
@ -1155,9 +1265,11 @@ findOrchSpends dbPath za (n:notes) = do
val (walletOrchNoteNullifier (entityVal n)))
pure (tx, orchSpends)
if null s
then findOrchSpends dbPath za notes
then findOrchSpends pool za notes
else do
PS.runSqlite dbPath $ do
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
_ <-
update $ \w -> do
set w [WalletOrchNoteSpent =. val True]
@ -1169,7 +1281,7 @@ findOrchSpends dbPath za (n:notes) = do
(entityKey n)
za
(walletOrchNoteValue $ entityVal n)
findOrchSpends dbPath za notes
findOrchSpends pool za notes
upsertWalTx ::
MonadIO m
@ -1186,22 +1298,24 @@ upsertWalTx zt za =
(zcashTransactionTime zt))
[]
getBalance :: T.Text -> ZcashAccountId -> IO Integer
getBalance dbPath za = do
trNotes <- getWalletUnspentTrNotes dbPath za
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 dbPath za
sapNotes <- getWalletUnspentSapNotes pool za
let sAmts = map (walletSapNoteValue . entityVal) sapNotes
let sBal = sum sAmts
orchNotes <- getWalletUnspentOrchNotes dbPath za
orchNotes <- getWalletUnspentOrchNotes pool za
let oAmts = map (walletOrchNoteValue . entityVal) orchNotes
let oBal = sum oAmts
return . fromIntegral $ tBal + sBal + oBal
clearWalletTransactions :: T.Text -> IO ()
clearWalletTransactions dbPath = do
PS.runSqlite dbPath $ do
clearWalletTransactions :: ConnectionPool -> IO ()
clearWalletTransactions pool = do
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
delete $ do
_ <- from $ table @WalletOrchSpend
return ()
@ -1227,9 +1341,12 @@ clearWalletTransactions dbPath = do
_ <- from $ table @UserTx
return ()
getWalletUnspentTrNotes :: T.Text -> ZcashAccountId -> IO [Entity WalletTrNote]
getWalletUnspentTrNotes dbPath za = do
PS.runSqlite dbPath $ do
getWalletUnspentTrNotes ::
ConnectionPool -> ZcashAccountId -> IO [Entity WalletTrNote]
getWalletUnspentTrNotes pool za = do
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
select $ do
n <- from $ table @WalletTrNote
where_ (n ^. WalletTrNoteAccId ==. val za)
@ -1237,9 +1354,11 @@ getWalletUnspentTrNotes dbPath za = do
pure n
getWalletUnspentSapNotes ::
T.Text -> ZcashAccountId -> IO [Entity WalletSapNote]
getWalletUnspentSapNotes dbPath za = do
PS.runSqlite dbPath $ do
ConnectionPool -> ZcashAccountId -> IO [Entity WalletSapNote]
getWalletUnspentSapNotes pool za = do
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
select $ do
n1 <- from $ table @WalletSapNote
where_ (n1 ^. WalletSapNoteAccId ==. val za)
@ -1247,9 +1366,11 @@ getWalletUnspentSapNotes dbPath za = do
pure n1
getWalletUnspentOrchNotes ::
T.Text -> ZcashAccountId -> IO [Entity WalletOrchNote]
getWalletUnspentOrchNotes dbPath za = do
PS.runSqlite dbPath $ do
ConnectionPool -> ZcashAccountId -> IO [Entity WalletOrchNote]
getWalletUnspentOrchNotes pool za = do
runNoLoggingT $
PS.retryOnBusy $
flip PS.runSqlPool pool $ do
select $ do
n2 <- from $ table @WalletOrchNote
where_ (n2 ^. WalletOrchNoteAccId ==. val za)
@ -1257,20 +1378,20 @@ getWalletUnspentOrchNotes dbPath za = do
pure n2
selectUnspentNotes ::
T.Text
ConnectionPool
-> ZcashAccountId
-> Integer
-> IO ([Entity WalletTrNote], [Entity WalletSapNote], [Entity WalletOrchNote])
selectUnspentNotes dbPath za amt = do
trNotes <- getWalletUnspentTrNotes dbPath za
selectUnspentNotes pool za amt = do
trNotes <- getWalletUnspentTrNotes pool za
let (a1, tList) = checkTransparent (fromIntegral amt) trNotes
if a1 > 0
then do
sapNotes <- getWalletUnspentSapNotes dbPath za
sapNotes <- getWalletUnspentSapNotes pool za
let (a2, sList) = checkSapling a1 sapNotes
if a2 > 0
then do
orchNotes <- getWalletUnspentOrchNotes dbPath za
orchNotes <- getWalletUnspentOrchNotes pool za
let (a3, oList) = checkOrchard a2 orchNotes
if a3 > 0
then throwIO $ userError "Not enough funds"
@ -1304,9 +1425,12 @@ selectUnspentNotes dbPath za amt = do
, n : snd (checkOrchard (x - walletOrchNoteValue (entityVal n)) ns))
else (0, [n])
getWalletTxId :: T.Text -> WalletTransactionId -> IO (Maybe (Value HexStringDB))
getWalletTxId dbPath wId = do
PS.runSqlite dbPath $ do
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)

70
src/Zenith/Scanner.hs
View file

@ -3,11 +3,23 @@
module Zenith.Scanner where
import Control.Exception (throwIO, try)
import qualified Control.Monad.Catch as CM (try)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger
( LoggingT
, NoLoggingT
, logErrorN
, logInfoN
, runNoLoggingT
)
import Data.Aeson
import Data.HexString
import Data.Maybe
import qualified Data.Text as T
import Data.Time (getCurrentTime)
import Database.Persist.Sqlite
import GHC.Utils.Monad (concatMapM)
import Lens.Micro ((&), (.~), (^.), set)
import System.Console.AsciiProgress
import ZcashHaskell.Types
( BlockResponse(..)
@ -30,64 +42,77 @@ scanZebra ::
-> T.Text -- ^ Host
-> Int -- ^ Port
-> T.Text -- ^ Path to database file
-> IO ()
-> NoLoggingT IO ()
scanZebra b host port dbFilePath = do
_ <- initDb dbFilePath
_ <- liftIO $ initDb dbFilePath
startTime <- liftIO getCurrentTime
logInfoN $ "Started sync: " <> T.pack (show startTime)
bc <-
try $ checkBlockChain host port :: IO
liftIO $ try $ checkBlockChain host port :: NoLoggingT
IO
(Either IOError ZebraGetBlockChainInfo)
case bc of
Left e -> print e
Left e -> logErrorN $ T.pack (show e)
Right bStatus -> do
dbBlock <- getMaxBlock dbFilePath
let dbInfo =
mkSqliteConnectionInfo dbFilePath & extraPragmas .~
["read_uncommited = true"]
pool <- createSqlitePoolFromInfo dbInfo 5
dbBlock <- getMaxBlock pool
let sb = max dbBlock b
if sb > zgb_blocks bStatus || sb < 1
then throwIO $ userError "Invalid starting block for scan"
then liftIO $ throwIO $ userError "Invalid starting block for scan"
else do
liftIO $
print $
"Scanning from " ++
show (sb + 1) ++ " to " ++ show (zgb_blocks bStatus)
let bList = [(sb + 1) .. (zgb_blocks bStatus)]
displayConsoleRegions $ do
pg <- newProgressBar def {pgTotal = fromIntegral $ length bList}
pg <-
liftIO $
newProgressBar def {pgTotal = fromIntegral $ length bList}
txList <-
try $ mapM_ (processBlock host port dbFilePath pg) bList :: IO
CM.try $ mapM_ (processBlock host port pool pg) bList :: NoLoggingT
IO
(Either IOError ())
case txList of
Left e1 -> print e1
Right txList' -> print txList'
Left e1 -> logErrorN $ T.pack (show e1)
Right txList' -> logInfoN "Finished scan"
-- | Function to process a raw block and extract the transaction information
processBlock ::
T.Text -- ^ Host name for `zebrad`
-> Int -- ^ Port for `zebrad`
-> T.Text -- ^ DB file path
-> ConnectionPool -- ^ DB file path
-> ProgressBar -- ^ Progress bar
-> Int -- ^ The block number to process
-> IO ()
processBlock host port dbFp pg b = do
-> NoLoggingT IO ()
processBlock host port pool pg b = do
r <-
liftIO $
makeZebraCall
host
port
"getblock"
[Data.Aeson.String $ T.pack $ show b, jsonNumber 1]
case r of
Left e -> throwIO $ userError e
Left e -> liftIO $ throwIO $ userError e
Right blk -> do
r2 <-
liftIO $
makeZebraCall
host
port
"getblock"
[Data.Aeson.String $ T.pack $ show b, jsonNumber 0]
case r2 of
Left e2 -> throwIO $ userError e2
Left e2 -> liftIO $ throwIO $ userError e2
Right hb -> do
let blockTime = getBlockTime hb
mapM_ (processTx host port blockTime dbFp) $
mapM_ (processTx host port blockTime pool) $
bl_txs $ addTime blk blockTime
tick pg
liftIO $ tick pg
where
addTime :: BlockResponse -> Int -> BlockResponse
addTime bl t =
@ -102,24 +127,25 @@ processTx ::
T.Text -- ^ Host name for `zebrad`
-> Int -- ^ Port for `zebrad`
-> Int -- ^ Block time
-> T.Text -- ^ DB file path
-> ConnectionPool -- ^ DB file path
-> HexString -- ^ transaction id
-> IO ()
processTx host port bt dbFp t = do
-> NoLoggingT IO ()
processTx host port bt pool t = do
r <-
liftIO $
makeZebraCall
host
port
"getrawtransaction"
[Data.Aeson.String $ toText t, jsonNumber 1]
case r of
Left e -> throwIO $ userError e
Left e -> liftIO $ throwIO $ userError e
Right rawTx -> do
case readZebraTransaction (ztr_hex rawTx) of
Nothing -> return ()
Just rzt -> do
_ <-
saveTransaction dbFp bt $
saveTransaction pool bt $
Transaction
t
(ztr_blockheight rawTx)

3
zenith.cabal
View file

@ -46,6 +46,7 @@ library
, bytestring
, esqueleto
, resource-pool
, exceptions
, monad-logger
, vty-crossplatform
, secp256k1-haskell
@ -61,6 +62,7 @@ library
, microlens-th
, mtl
, persistent
, Hclip
, persistent-sqlite
, persistent-template
, process
@ -105,6 +107,7 @@ executable zenscan
build-depends:
base >=4.12 && <5
, configurator
, monad-logger
, zenith
pkgconfig-depends: rustzcash_wrapper
default-language: Haskell2010