Implement background sync

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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