From dcbb2fac4ac55d28fb8fcb47cfb56999a709d137 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Sun, 5 May 2024 09:49:55 -0500 Subject: [PATCH 1/2] Implement background sync --- app/Main.hs | 3 +- app/ZenScan.hs | 3 +- src/Zenith/CLI.hs | 284 ++++++++---- src/Zenith/Core.hs | 250 +++++------ src/Zenith/DB.hs | 988 ++++++++++++++++++++++++------------------ src/Zenith/Scanner.hs | 72 ++- zenith.cabal | 3 + 7 files changed, 916 insertions(+), 687 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 39d5f30..eb13ce7 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/app/ZenScan.hs b/app/ZenScan.hs index fd7530e..05059ca 100644 --- a/app/ZenScan.hs +++ b/app/ZenScan.hs @@ -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 diff --git a/src/Zenith/CLI.hs b/src/Zenith/CLI.hs index f0d64be..10868f1 100644 --- a/src/Zenith/CLI.hs +++ b/src/Zenith/CLI.hs @@ -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 - case s ^. displayBox of - SyncDisplay -> do - if s ^. barValue == 1.0 - then BT.modify $ set displayBox BlankDisplay - else BT.modify $ set displayBox SyncDisplay - _ -> return () + 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 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) diff --git a/src/Zenith/Core.hs b/src/Zenith/Core.hs index 878ffba..8122f5a 100644 --- a/src/Zenith/Core.hs +++ b/src/Zenith/Core.hs @@ -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,56 +396,41 @@ 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 - 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" + 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 -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 - cmxs <- liftIO $ getOrchardCmxs pool noteSync - let cmxList = map (\(ESQ.Value x) -> getHex x) cmxs - let newWitness = - updateOrchardWitness - (OrchardWitness $ getHex $ walletOrchNoteWitness $ entityVal n) - cmxList - liftIO $ updateOrchNoteRecord pool (entityKey n) newWitness maxId - else logInfoN "Witness up to date" + when (noteSync < maxId) $ do + cmxs <- liftIO $ getOrchardCmxs pool noteSync + let cmxList = map (\(ESQ.Value x) -> getHex x) cmxs + let newWitness = + updateOrchardWitness + (OrchardWitness $ getHex $ walletOrchNoteWitness $ entityVal n) + cmxList + liftIO $ updateOrchNoteRecord pool (entityKey n) newWitness maxId -- | 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 diff --git a/src/Zenith/DB.hs b/src/Zenith/DB.hs index 6f352af..67d9527 100644 --- a/src/Zenith/DB.hs +++ b/src/Zenith/DB.hs @@ -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,167 +266,192 @@ 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 $ - select $ do - wallets <- from $ table @ZcashWallet - where_ (wallets ^. ZcashWalletNetwork ==. val (ZcashNetDB n)) - pure wallets +getWallets :: ConnectionPool -> ZcashNet -> IO [Entity ZcashWallet] +getWallets pool n = + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + wallets <- from $ table @ZcashWallet + where_ (wallets ^. ZcashWalletNetwork ==. val (ZcashNetDB n)) + pure wallets -- | Save a new wallet to the database saveWallet :: - 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 - update $ \w -> do - set w [ZcashWalletLastSync =. val b] - where_ $ w ^. ZcashWalletId ==. val i +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 $ - 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 $ - selectOne $ do + -> NoLoggingT IO [Entity ZcashAccount] +getAccounts pool w = + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do accs <- from $ table @ZcashAccount - where_ (accs ^. ZcashAccountId ==. val za) + where_ (accs ^. ZcashAccountWalletId ==. val w) pure accs +getAccountById :: + ConnectionPool -> ZcashAccountId -> IO (Maybe (Entity ZcashAccount)) +getAccountById pool za = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + accs <- from $ table @ZcashAccount + where_ (accs ^. ZcashAccountId ==. val za) + pure accs + -- | Returns the largest account index for the given wallet getMaxAccount :: - 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 $ - selectOne $ do - accs <- from $ table @ZcashAccount - where_ (accs ^. ZcashAccountWalletId ==. val w) - orderBy [desc $ accs ^. ZcashAccountIndex] - pure accs + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + accs <- from $ table @ZcashAccount + where_ (accs ^. ZcashAccountWalletId ==. val w) + orderBy [desc $ accs ^. ZcashAccountIndex] + pure accs case a of Nothing -> return $ -1 Just x -> return $ zcashAccountIndex $ entityVal x -- | Save a new account to the database saveAccount :: - 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 $ - selectOne $ do - txs <- from $ table @ZcashTransaction - where_ (txs ^. ZcashTransactionBlock >. val 0) - orderBy [desc $ txs ^. ZcashTransactionBlock] - pure txs + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + txs <- from $ table @ZcashTransaction + where_ (txs ^. ZcashTransactionBlock >. val 0) + orderBy [desc $ txs ^. ZcashTransactionBlock] + pure txs case b of Nothing -> return $ -1 Just x -> return $ zcashTransactionBlock $ entityVal x -- | Returns a list of addresses associated with the given account getAddresses :: - T.Text -- ^ The database path + ConnectionPool -- ^ The database path -> ZcashAccountId -- ^ The account ID to check - -> IO [Entity WalletAddress] -getAddresses dbFp a = - PS.runSqlite dbFp $ - select $ do - addrs <- from $ table @WalletAddress - where_ (addrs ^. WalletAddressAccId ==. val a) - where_ (addrs ^. WalletAddressScope ==. val (ScopeDB External)) - pure addrs + -> 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 $ - selectOne $ do - addr <- from $ table @WalletAddress - where_ (addr ^. WalletAddressId ==. val a) - pure addr +getAddressById :: + ConnectionPool -> WalletAddressId -> IO (Maybe (Entity WalletAddress)) +getAddressById pool a = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + addr <- from $ table @WalletAddress + where_ (addr ^. WalletAddressId ==. val a) + pure addr -- | Returns a list of change addresses associated with the given account getInternalAddresses :: - T.Text -- ^ The database path + ConnectionPool -- ^ The database path -> ZcashAccountId -- ^ The account ID to check - -> IO [Entity WalletAddress] -getInternalAddresses dbFp a = - PS.runSqlite dbFp $ - select $ do - addrs <- from $ table @WalletAddress - where_ (addrs ^. WalletAddressAccId ==. val a) - where_ (addrs ^. WalletAddressScope ==. val (ScopeDB Internal)) - pure addrs + -> NoLoggingT IO [Entity WalletAddress] +getInternalAddresses pool a = + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + addrs <- from $ table @WalletAddress + where_ (addrs ^. WalletAddressAccId ==. val a) + where_ (addrs ^. WalletAddressScope ==. val (ScopeDB Internal)) + pure addrs -- | Returns a list of addressess associated with the given wallet getWalletAddresses :: - 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 $ - selectOne $ do - addrs <- from $ table @WalletAddress - where_ $ addrs ^. WalletAddressAccId ==. val aw - where_ $ addrs ^. WalletAddressScope ==. val (ScopeDB s) - orderBy [desc $ addrs ^. WalletAddressIndex] - pure addrs + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + addrs <- from $ table @WalletAddress + where_ $ addrs ^. WalletAddressAccId ==. val aw + where_ $ addrs ^. WalletAddressScope ==. val (ScopeDB s) + orderBy [desc $ addrs ^. WalletAddressIndex] + pure addrs case a of Nothing -> return $ -1 Just x -> return $ walletAddressIndex $ entityVal x -- | Save a new address to the database saveAddress :: - 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,70 +532,78 @@ 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 $ - select $ do - txs <- from $ table @ZcashTransaction - where_ $ txs ^. ZcashTransactionBlock >. val b - orderBy [asc $ txs ^. ZcashTransactionBlock] - return txs +getZcashTransactions pool b = + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + txs <- from $ table @ZcashTransaction + where_ $ txs ^. ZcashTransactionBlock >. val b + orderBy [asc $ txs ^. ZcashTransactionBlock] + return txs -- * 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 $ - selectOne $ do - txs <- from $ table @WalletTransaction - where_ $ txs ^. WalletTransactionBlock >. val 0 - orderBy [desc $ txs ^. WalletTransactionBlock] - return txs + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + txs <- from $ table @WalletTransaction + where_ $ txs ^. WalletTransactionBlock >. val 0 + orderBy [desc $ txs ^. WalletTransactionBlock] + return txs case b of Nothing -> return $ -1 Just x -> return $ walletTransactionBlock $ entityVal x -getMinBirthdayHeight :: T.Text -> IO Int -getMinBirthdayHeight dbPath = do +getMinBirthdayHeight :: ConnectionPool -> IO Int +getMinBirthdayHeight pool = do b <- - PS.runSqlite dbPath $ - selectOne $ do - w <- from $ table @ZcashWallet - where_ (w ^. ZcashWalletBirthdayHeight >. val 0) - orderBy [asc $ w ^. ZcashWalletBirthdayHeight] - pure w + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + w <- from $ table @ZcashWallet + where_ (w ^. ZcashWalletBirthdayHeight >. val 0) + orderBy [asc $ w ^. ZcashWalletBirthdayHeight] + pure w case b of Nothing -> return 0 Just x -> return $ zcashWalletBirthdayHeight $ entityVal x -- | 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 - t <- - upsert - (WalletTransaction - (zcashTransactionTxId zT') - za - (zcashTransactionBlock zT') - (zcashTransactionConf zT') - (zcashTransactionTime zT')) - [] - return $ entityKey t + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + t <- + upsert + (WalletTransaction + (zcashTransactionTxId zT') + za + (zcashTransactionBlock zT') + (zcashTransactionConf zT') + (zcashTransactionTime zT')) + [] + return $ entityKey t -- | Save a @WalletSapNote@ saveWalletSapNote :: - 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,29 +612,31 @@ saveWalletSapNote :: -> ShieldOutputId -> DecodedNote -- The decoded Sapling note -> IO () -saveWalletSapNote dbPath wId pos wit ch za zt dn = do - PS.runSqlite dbPath $ do - _ <- - upsert - (WalletSapNote - wId - za - (fromIntegral $ a_value dn) - (a_recipient dn) - (T.filter (/= '\NUL') $ TE.decodeUtf8Lenient $ a_memo dn) - False - (HexStringDB $ a_nullifier dn) - (fromIntegral pos) - (HexStringDB $ sapWit wit) - ch - zt - (RseedDB $ a_rseed dn)) - [] - return () +saveWalletSapNote pool wId pos wit ch za zt dn = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + _ <- + upsert + (WalletSapNote + wId + za + (fromIntegral $ a_value dn) + (a_recipient dn) + (T.filter (/= '\NUL') $ TE.decodeUtf8Lenient $ a_memo dn) + False + (HexStringDB $ a_nullifier dn) + (fromIntegral pos) + (HexStringDB $ sapWit wit) + ch + zt + (RseedDB $ a_rseed dn)) + [] + return () -- | Save a @WalletOrchNote@ saveWalletOrchNote :: - T.Text + ConnectionPool -> WalletTransactionId -> Integer -> OrchardWitness @@ -603,34 +645,36 @@ saveWalletOrchNote :: -> OrchActionId -> DecodedNote -> IO () -saveWalletOrchNote dbPath wId pos wit ch za zt dn = do - PS.runSqlite dbPath $ do - _ <- - upsert - (WalletOrchNote - wId - za - (fromIntegral $ a_value dn) - (a_recipient dn) - (T.filter (/= '\NUL') $ TE.decodeUtf8Lenient $ a_memo dn) - False - (HexStringDB $ a_nullifier dn) - (fromIntegral pos) - (HexStringDB $ orchWit wit) - ch - zt - (a_rho dn) - (RseedDB $ a_rseed dn)) - [] - return () +saveWalletOrchNote pool wId pos wit ch za zt dn = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + _ <- + upsert + (WalletOrchNote + wId + za + (fromIntegral $ a_value dn) + (a_recipient dn) + (T.filter (/= '\NUL') $ TE.decodeUtf8Lenient $ a_memo dn) + False + (HexStringDB $ a_nullifier dn) + (fromIntegral pos) + (HexStringDB $ orchWit wit) + ch + zt + (a_rho dn) + (RseedDB $ a_rseed dn)) + [] + return () -- | Find the Transparent Notes that match the given transparent receiver findTransparentNotes :: - 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,18 +685,20 @@ findTransparentNotes dbPath b t = do , BS.pack [0x88, 0xAC] ] tN <- - PS.runSqlite dbPath $ - select $ do - (txs :& tNotes) <- - from $ table @ZcashTransaction `innerJoin` table @TransparentNote `on` - (\(txs :& tNotes) -> - txs ^. ZcashTransactionId ==. tNotes ^. TransparentNoteTx) - where_ (txs ^. ZcashTransactionBlock >. val b) - where_ (tNotes ^. TransparentNoteScript ==. val s) - pure (txs, tNotes) + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + (txs :& tNotes) <- + from $ table @ZcashTransaction `innerJoin` table @TransparentNote `on` + (\(txs :& tNotes) -> + txs ^. ZcashTransactionId ==. tNotes ^. TransparentNoteTx) + where_ (txs ^. ZcashTransactionBlock >. val b) + where_ (tNotes ^. TransparentNoteScript ==. val s) + pure (txs, tNotes) mapM_ (saveWalletTrNote - dbPath + pool (getScope $ walletAddressScope $ entityVal t) (walletAddressAccId $ entityVal t) (entityKey t)) @@ -661,46 +707,51 @@ 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 - t <- - upsert - (WalletTransaction - (zcashTransactionTxId zT') - za - (zcashTransactionBlock zT') - (zcashTransactionConf zT') - (zcashTransactionTime zT')) - [] - insert_ $ - WalletTrNote - (entityKey t) - za - wa - (transparentNoteValue $ entityVal tn) - False - (transparentNoteScript $ entityVal tn) - (ch == Internal) - (fromIntegral $ transparentNotePosition $ entityVal tn) + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + t <- + upsert + (WalletTransaction + (zcashTransactionTxId zT') + za + (zcashTransactionBlock zT') + (zcashTransactionConf zT') + (zcashTransactionTime zT')) + [] + insert_ $ + WalletTrNote + (entityKey t) + za + wa + (transparentNoteValue $ entityVal tn) + False + (transparentNoteScript $ entityVal tn) + (ch == Internal) + (fromIntegral $ transparentNotePosition $ entityVal tn) -- | Save a Sapling note to the wallet database -saveSapNote :: 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,11 +807,12 @@ getWalletTransactions dbPath w = do , (toBytes . tr_bytes) tR , BS.pack [0x88, 0xAC] ] - PS.runSqlite dbPath $ do - select $ do - tnotes <- from $ table @WalletTrNote - where_ (tnotes ^. WalletTrNoteScript ==. val s) - pure tnotes + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + tnotes <- from $ table @WalletTrNote + where_ (tnotes ^. WalletTrNoteScript ==. val s) + pure tnotes trChgNotes <- case ctReceiver of Nothing -> return [] @@ -769,13 +823,15 @@ getWalletTransactions dbPath w = do , (toBytes . tr_bytes) tR , BS.pack [0x88, 0xAC] ] - PS.runSqlite dbPath $ do - select $ do - tnotes <- from $ table @WalletTrNote - where_ (tnotes ^. WalletTrNoteScript ==. val s1) - pure tnotes + 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,40 +842,45 @@ getWalletTransactions dbPath w = do case sReceiver of Nothing -> return [] Just sR -> do - PS.runSqlite dbPath $ do - select $ do - snotes <- from $ table @WalletSapNote - where_ (snotes ^. WalletSapNoteRecipient ==. val (getBytes sR)) - pure snotes + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + snotes <- from $ table @WalletSapNote + where_ (snotes ^. WalletSapNoteRecipient ==. val (getBytes sR)) + pure snotes sapChgNotes <- case csReceiver of Nothing -> return [] Just sR -> do - PS.runSqlite dbPath $ do - select $ do - snotes <- from $ table @WalletSapNote - where_ (snotes ^. WalletSapNoteRecipient ==. val (getBytes sR)) - pure snotes + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + snotes <- from $ table @WalletSapNote + where_ (snotes ^. WalletSapNoteRecipient ==. val (getBytes sR)) + pure snotes sapSpends <- mapM (getSapSpends . entityKey) (sapNotes <> sapChgNotes) orchNotes <- case oReceiver of Nothing -> return [] Just oR -> do - PS.runSqlite dbPath $ do - select $ do - onotes <- from $ table @WalletOrchNote - where_ (onotes ^. WalletOrchNoteRecipient ==. val (getBytes oR)) - pure onotes + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + onotes <- from $ table @WalletOrchNote + where_ (onotes ^. WalletOrchNoteRecipient ==. val (getBytes oR)) + pure onotes orchChgNotes <- case coReceiver of Nothing -> return [] Just oR -> do - PS.runSqlite dbPath $ do - select $ do - onotes <- from $ table @WalletOrchNote - where_ (onotes ^. WalletOrchNoteRecipient ==. val (getBytes oR)) - pure onotes + 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 - selectOne $ do - sapSpends <- from $ table @WalletSapSpend - where_ (sapSpends ^. WalletSapSpendNote ==. val n) - pure sapSpends - getOrchSpends :: WalletOrchNoteId -> IO (Maybe (Entity WalletOrchSpend)) + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + sapSpends <- from $ table @WalletSapSpend + where_ (sapSpends ^. WalletSapSpendNote ==. val n) + pure sapSpends + getOrchSpends :: + WalletOrchNoteId -> NoLoggingT IO (Maybe (Entity WalletOrchSpend)) getOrchSpends n = do - PS.runSqlite dbPath $ do - selectOne $ do - orchSpends <- from $ table @WalletOrchSpend - where_ (orchSpends ^. WalletOrchSpendNote ==. val n) - pure orchSpends - addTr :: Entity WalletTrNote -> IO () + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + orchSpends <- from $ table @WalletOrchSpend + where_ (orchSpends ^. WalletOrchSpendNote ==. val n) + pure orchSpends + addTr :: Entity WalletTrNote -> NoLoggingT IO () addTr n = upsertUserTx (walletTrNoteTx $ entityVal n) (entityKey w) (fromIntegral $ walletTrNoteValue $ entityVal n) "" - addSap :: Entity WalletSapNote -> 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 - select $ do - uTxs <- from $ table @UserTx - where_ (uTxs ^. UserTxAddress ==. val aId) - return uTxs +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 - select $ do - n <- from $ table @WalletTrNote - where_ (n ^. WalletTrNoteAccId ==. val za) - pure n +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,33 +1075,41 @@ findTransparentSpends dbPath za = do if null s then return () else do - PS.runSqlite dbPath $ do - _ <- - update $ \w -> do - set w [WalletTrNoteSpent =. val True] - where_ $ w ^. WalletTrNoteId ==. val (entityKey n) - t' <- upsertWalTx (entityVal $ fst $ head s) za - insert_ $ - WalletTrSpend - (entityKey t') - (entityKey n) - za - (walletTrNoteValue $ entityVal n) + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + _ <- + update $ \w -> do + set w [WalletTrNoteSpent =. val True] + where_ $ w ^. WalletTrNoteId ==. val (entityKey n) + t' <- upsertWalTx (entityVal $ fst $ head s) za + insert_ $ + WalletTrSpend + (entityKey t') + (entityKey n) + za + (walletTrNoteValue $ entityVal n) -getWalletSapNotes :: T.Text -> ZcashAccountId -> IO [Entity WalletSapNote] -getWalletSapNotes dbPath za = do - PS.runSqlite dbPath $ do - select $ do - n <- from $ table @WalletSapNote - where_ (n ^. WalletSapNoteAccId ==. val za) - pure n +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,37 +1120,44 @@ 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 - _ <- - update $ \w -> do - set w [WalletSapNoteSpent =. val True] - where_ $ w ^. WalletSapNoteId ==. val (entityKey n) - t' <- upsertWalTx (entityVal $ fst $ head s) za - insert_ $ - WalletSapSpend - (entityKey t') - (entityKey n) - za - (walletSapNoteValue $ entityVal n) - findSapSpends dbPath za notes + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + _ <- + update $ \w -> do + set w [WalletSapNoteSpent =. val True] + where_ $ w ^. WalletSapNoteId ==. val (entityKey n) + t' <- upsertWalTx (entityVal $ fst $ head s) za + insert_ $ + WalletSapSpend + (entityKey t') + (entityKey n) + za + (walletSapNoteValue $ entityVal n) + findSapSpends pool za notes -getWalletOrchNotes :: T.Text -> ZcashAccountId -> IO [Entity WalletOrchNote] -getWalletOrchNotes dbPath za = do - PS.runSqlite dbPath $ do - select $ do - n <- from $ table @WalletOrchNote - where_ (n ^. WalletOrchNoteAccId ==. val za) - pure n +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 - select $ do - n <- from $ table @WalletSapNote - where_ (n ^. WalletSapNoteSpent ==. val False) - pure n +getUnspentSapNotes :: ConnectionPool -> IO [Entity WalletSapNote] +getUnspentSapNotes pool = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + n <- from $ table @WalletSapNote + where_ (n ^. WalletSapNoteSpent ==. val False) + pure n getSaplingCmus :: Pool SqlBackend -> ShieldOutputId -> IO [Value HexStringDB] getSaplingCmus pool zt = do @@ -1093,13 +1198,15 @@ updateSapNoteRecord pool n w o = do ] where_ (x ^. WalletSapNoteId ==. val n) -getUnspentOrchNotes :: T.Text -> IO [Entity WalletOrchNote] -getUnspentOrchNotes dbPath = do - PS.runSqlite dbPath $ do - select $ do - n <- from $ table @WalletOrchNote - where_ (n ^. WalletOrchNoteSpent ==. val False) - pure n +getUnspentOrchNotes :: ConnectionPool -> IO [Entity WalletOrchNote] +getUnspentOrchNotes pool = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + select $ do + n <- from $ table @WalletOrchNote + where_ (n ^. WalletOrchNoteSpent ==. val False) + pure n getOrchardCmxs :: Pool SqlBackend -> OrchActionId -> IO [Value HexStringDB] getOrchardCmxs pool zt = do @@ -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,21 +1265,23 @@ 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 - _ <- - update $ \w -> do - set w [WalletOrchNoteSpent =. val True] - where_ $ w ^. WalletOrchNoteId ==. val (entityKey n) - t' <- upsertWalTx (entityVal $ fst $ head s) za - insert_ $ - WalletOrchSpend - (entityKey t') - (entityKey n) - za - (walletOrchNoteValue $ entityVal n) - findOrchSpends dbPath za notes + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + _ <- + update $ \w -> do + set w [WalletOrchNoteSpent =. val True] + where_ $ w ^. WalletOrchNoteId ==. val (entityKey n) + t' <- upsertWalTx (entityVal $ fst $ head s) za + insert_ $ + WalletOrchSpend + (entityKey t') + (entityKey n) + za + (walletOrchNoteValue $ entityVal n) + findOrchSpends pool za notes upsertWalTx :: MonadIO m @@ -1186,91 +1298,100 @@ 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 - delete $ do - _ <- from $ table @WalletOrchSpend - return () - delete $ do - _ <- from $ table @WalletOrchNote - return () - delete $ do - _ <- from $ table @WalletSapSpend - return () - delete $ do - _ <- from $ table @WalletSapNote - return () - delete $ do - _ <- from $ table @WalletTrNote - return () - delete $ do - _ <- from $ table @WalletTrSpend - return () - delete $ do - _ <- from $ table @WalletTransaction - return () - delete $ do - _ <- from $ table @UserTx - return () +clearWalletTransactions :: ConnectionPool -> IO () +clearWalletTransactions pool = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + delete $ do + _ <- from $ table @WalletOrchSpend + return () + delete $ do + _ <- from $ table @WalletOrchNote + return () + delete $ do + _ <- from $ table @WalletSapSpend + return () + delete $ do + _ <- from $ table @WalletSapNote + return () + delete $ do + _ <- from $ table @WalletTrNote + return () + delete $ do + _ <- from $ table @WalletTrSpend + return () + delete $ do + _ <- from $ table @WalletTransaction + return () + delete $ do + _ <- from $ table @UserTx + return () -getWalletUnspentTrNotes :: T.Text -> ZcashAccountId -> IO [Entity WalletTrNote] -getWalletUnspentTrNotes dbPath za = do - PS.runSqlite dbPath $ do - select $ do - n <- from $ table @WalletTrNote - where_ (n ^. WalletTrNoteAccId ==. val za) - where_ (n ^. WalletTrNoteSpent ==. val False) - pure n +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) + where_ (n ^. WalletTrNoteSpent ==. val False) + pure n getWalletUnspentSapNotes :: - T.Text -> ZcashAccountId -> IO [Entity WalletSapNote] -getWalletUnspentSapNotes dbPath za = do - PS.runSqlite dbPath $ do - select $ do - n1 <- from $ table @WalletSapNote - where_ (n1 ^. WalletSapNoteAccId ==. val za) - where_ (n1 ^. WalletSapNoteSpent ==. val False) - pure n1 + 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) + where_ (n1 ^. WalletSapNoteSpent ==. val False) + pure n1 getWalletUnspentOrchNotes :: - T.Text -> ZcashAccountId -> IO [Entity WalletOrchNote] -getWalletUnspentOrchNotes dbPath za = do - PS.runSqlite dbPath $ do - select $ do - n2 <- from $ table @WalletOrchNote - where_ (n2 ^. WalletOrchNoteAccId ==. val za) - where_ (n2 ^. WalletOrchNoteSpent ==. val False) - pure n2 + 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) + where_ (n2 ^. WalletOrchNoteSpent ==. val False) + 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,13 +1425,16 @@ 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 - selectOne $ do - wtx <- from $ table @WalletTransaction - where_ (wtx ^. WalletTransactionId ==. val wId) - pure $ wtx ^. WalletTransactionTxId +getWalletTxId :: + ConnectionPool -> WalletTransactionId -> IO (Maybe (Value HexStringDB)) +getWalletTxId pool wId = do + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + wtx <- from $ table @WalletTransaction + where_ (wtx ^. WalletTransactionId ==. val wId) + pure $ wtx ^. WalletTransactionTxId -- | Helper function to extract a Unified Address from the database readUnifiedAddressDB :: WalletAddress -> Maybe UnifiedAddress diff --git a/src/Zenith/Scanner.hs b/src/Zenith/Scanner.hs index 8d49a74..df47ed1 100644 --- a/src/Zenith/Scanner.hs +++ b/src/Zenith/Scanner.hs @@ -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 - print $ + 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) diff --git a/zenith.cabal b/zenith.cabal index df4e9fa..41d11ff 100644 --- a/zenith.cabal +++ b/zenith.cabal @@ -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 From e20f253cda1991ea8c7b5f3ae6147286def16e13 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 9 May 2024 10:44:07 -0500 Subject: [PATCH 2/2] Improve the fee calculation --- src/Zenith/CLI.hs | 241 +++++++++++++++++++++++++++++++++++++++++--- src/Zenith/Core.hs | 116 +++++++++++++-------- src/Zenith/DB.hs | 90 +++++++++++------ src/Zenith/Utils.hs | 12 +-- test/Spec.hs | 115 ++++++++++++++++----- zcash-haskell | 2 +- zenith.cabal | 2 + 7 files changed, 459 insertions(+), 119 deletions(-) diff --git a/src/Zenith/CLI.hs b/src/Zenith/CLI.hs index 10868f1..4dabde1 100644 --- a/src/Zenith/CLI.hs +++ b/src/Zenith/CLI.hs @@ -11,11 +11,15 @@ import qualified Brick.Focus as F import Brick.Forms ( Form(..) , (@@=) + , allFieldsValid + , editShowableFieldWithValidate , editTextField , focusedFormInputAttr , handleFormEvent + , invalidFormInputAttr , newForm , renderForm + , setFieldValid , updateFormState ) import qualified Brick.Main as M @@ -49,6 +53,7 @@ import Brick.Widgets.Core , withBorderStyle ) import qualified Brick.Widgets.Dialog as D +import qualified Brick.Widgets.Edit as E import qualified Brick.Widgets.List as L import qualified Brick.Widgets.ProgressBar as P import Control.Concurrent (forkIO, threadDelay) @@ -57,6 +62,7 @@ import Control.Monad (forever, void) import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger (LoggingT, runFileLoggingT, runNoLoggingT) import Data.Aeson +import Data.HexString (toText) import Data.Maybe import qualified Data.Text as T import qualified Data.Text.Encoding as E @@ -73,7 +79,12 @@ import System.Hclip import Text.Wrap (FillScope(..), FillStrategy(..), WrapSettings(..), wrapText) import ZcashHaskell.Keys (generateWalletSeedPhrase, getWalletSeed) import ZcashHaskell.Orchard (getSaplingFromUA, isValidUnifiedAddress) -import ZcashHaskell.Transparent (encodeTransparentReceiver) +import ZcashHaskell.Sapling (decodeSaplingAddress, isValidShieldedAddress) +import ZcashHaskell.Transparent + ( decodeExchangeAddress + , decodeTransparentAddress + , encodeTransparentReceiver + ) import ZcashHaskell.Types import ZcashHaskell.Utils (getBlockTime, makeZebraCall) import Zenith.Core @@ -94,6 +105,9 @@ data Name | TList | HelpDialog | DialogInputField + | RecField + | AmtField + | MemoField deriving (Eq, Show, Ord) data DialogInput = DialogInput @@ -102,12 +116,21 @@ data DialogInput = DialogInput makeLenses ''DialogInput +data SendInput = SendInput + { _sendTo :: !T.Text + , _sendAmt :: !Float + , _sendMemo :: !T.Text + } deriving (Show) + +makeLenses ''SendInput + data DialogType = WName | AName | AdName | WSelect | ASelect + | SendTx | Blank data DisplayType @@ -116,6 +139,7 @@ data DisplayType | PhraseDisplay | TxDisplay | SyncDisplay + | SendDisplay | BlankDisplay data Tick @@ -144,6 +168,7 @@ data State = State , _barValue :: !Float , _eventDispatch :: !(BC.BChan Tick) , _timer :: !Int + , _txForm :: !(Form SendInput () Name) } makeLenses ''State @@ -182,7 +207,7 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] listAddressBox "Addresses" (st ^. addresses) <+> B.vBorder <+> (C.hCenter (str ("Last block seen: " ++ show (st ^. syncBlock))) <=> - listTxBox "Transactions" (st ^. transactions))) <=> + listTxBox "Transactions" (st ^. network) (st ^. transactions))) <=> C.hCenter (hBox [ capCommand "W" "allets" @@ -230,13 +255,14 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] , capCommand "Tab " "->" ]) ] - listTxBox :: String -> L.List Name (Entity UserTx) -> Widget Name - listTxBox titleLabel tx = + listTxBox :: + String -> ZcashNet -> L.List Name (Entity UserTx) -> Widget Name + listTxBox titleLabel znet tx = C.vCenter $ vBox [ C.hCenter (B.borderWithLabel (str titleLabel) $ - hLimit 40 $ vLimit 15 $ L.renderList listDrawTx True tx) + hLimit 50 $ vLimit 15 $ L.renderList (listDrawTx znet) True tx) , str " " , C.hCenter (hBox @@ -303,6 +329,12 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] , capCommand "N" "ew" , xCommand ])) + SendTx -> + D.renderDialog + (D.dialog (Just (str "Send Transaction")) Nothing 50) + (renderForm (st ^. txForm) <=> + C.hCenter + (hBox [capCommand "↲ " "Send", capCommand " " "Cancel"])) Blank -> emptyWidget splashDialog :: State -> Widget Name splashDialog st = @@ -421,6 +453,11 @@ drawUI s = [splashDialog s, helpDialog s, displayDialog s, inputDialog s, ui s] (P.progressBar (Just $ show (st ^. barValue * 100)) (_barValue st)))) + SendDisplay -> + withBorderStyle unicodeBold $ + D.renderDialog + (D.dialog (Just $ txt "Sending Transaction") Nothing 50) + (padAll 1 (str $ st ^. msg)) BlankDisplay -> emptyWidget mkInputForm :: DialogInput -> Form DialogInput e Name @@ -431,6 +468,33 @@ mkInputForm = label s w = padBottom (Pad 1) $ vLimit 1 (hLimit 15 $ str s <+> fill ' ') <+> w +mkSendForm :: Integer -> SendInput -> Form SendInput e Name +mkSendForm bal = + newForm + [ label "To: " @@= editTextField sendTo RecField (Just 1) + , label "Amount: " @@= + editShowableFieldWithValidate sendAmt AmtField (isAmountValid bal) + , label "Memo: " @@= editTextField sendMemo MemoField (Just 1) + ] + where + isAmountValid :: Integer -> Float -> Bool + isAmountValid b i = (fromIntegral b * 100000000.0) >= i + label s w = + padBottom (Pad 1) $ vLimit 1 (hLimit 15 $ str s <+> fill ' ') <+> w + +isRecipientValid :: T.Text -> Bool +isRecipientValid a = + case isValidUnifiedAddress (E.encodeUtf8 a) of + Just _a1 -> True + Nothing -> + isValidShieldedAddress (E.encodeUtf8 a) || + (case decodeTransparentAddress (E.encodeUtf8 a) of + Just _a3 -> True + Nothing -> + case decodeExchangeAddress a of + Just _a4 -> True + Nothing -> False) + listDrawElement :: (Show a) => Bool -> a -> Widget Name listDrawElement sel a = let selStr s = @@ -466,18 +530,22 @@ listDrawAddress sel w = walletAddressName (entityVal w) <> ": " <> showAddress (walletAddressUAddress (entityVal w)) -listDrawTx :: Bool -> Entity UserTx -> Widget Name -listDrawTx sel tx = +listDrawTx :: ZcashNet -> Bool -> Entity UserTx -> Widget Name +listDrawTx znet sel tx = selStr $ T.pack (show $ posixSecondsToUTCTime (fromIntegral (userTxTime $ entityVal tx))) <> - " " <> fmtAmt + " " <> T.pack fmtAmt where - amt = fromIntegral (userTxAmount $ entityVal tx) / 100000000 + amt = fromIntegral $ userTxAmount $ entityVal tx + dispAmount = + if znet == MainNet + then displayZec amt + else displayTaz amt fmtAmt = if amt > 0 - then "↘" <> T.pack (show amt) <> " " - else " " <> T.pack (show amt) <> "↗" + then "↘" <> dispAmount <> " " + else " " <> dispAmount <> "↗" selStr s = if sel then withAttr customAttr (txt $ "> " <> s) @@ -561,14 +629,22 @@ appEvent (BT.AppEvent t) = do pool <- liftIO $ runNoLoggingT $ initPool $ s ^. dbPath case t of TickMsg m -> do - BT.modify $ set msg m - BT.modify $ set displayBox MsgDisplay + case s ^. displayBox of + AddrDisplay -> return () + MsgDisplay -> return () + PhraseDisplay -> return () + TxDisplay -> return () + SyncDisplay -> return () + SendDisplay -> do + BT.modify $ set msg m + BlankDisplay -> return () TickVal v -> do case s ^. displayBox of AddrDisplay -> return () MsgDisplay -> return () PhraseDisplay -> return () TxDisplay -> return () + SendDisplay -> return () SyncDisplay -> do if s ^. barValue == 1.0 then do @@ -600,6 +676,7 @@ appEvent (BT.AppEvent t) = do WName -> return () WSelect -> return () ASelect -> return () + SendTx -> return () Blank -> do if s ^. timer == 90 then do @@ -643,6 +720,11 @@ appEvent (BT.VtyEvent e) = do setClipboard $ T.unpack $ getUA $ walletAddressUAddress $ entityVal a + BT.modify $ + set msg $ + "Copied Unified Address <" ++ + T.unpack (walletAddressName (entityVal a)) ++ ">!" + BT.modify $ set displayBox MsgDisplay Nothing -> return () V.EvKey (V.KChar 's') [] -> do case L.listSelectedElement $ s ^. addresses of @@ -653,6 +735,11 @@ appEvent (BT.VtyEvent e) = do getSaplingFromUA $ E.encodeUtf8 $ getUA $ walletAddressUAddress $ entityVal a + BT.modify $ + set msg $ + "Copied Sapling Address <" ++ + T.unpack (walletAddressName (entityVal a)) ++ ">!" + BT.modify $ set displayBox MsgDisplay Nothing -> return () V.EvKey (V.KChar 't') [] -> do case L.listSelectedElement $ s ^. addresses of @@ -667,11 +754,17 @@ appEvent (BT.VtyEvent e) = do (isValidUnifiedAddress . E.encodeUtf8 . getUA . walletAddressUAddress) (entityVal a) + BT.modify $ + set msg $ + "Copied Transparent Address <" ++ + T.unpack (walletAddressName (entityVal a)) ++ ">!" + BT.modify $ set displayBox MsgDisplay Nothing -> return () _ev -> return () MsgDisplay -> BT.modify $ set displayBox BlankDisplay PhraseDisplay -> BT.modify $ set displayBox BlankDisplay TxDisplay -> BT.modify $ set displayBox BlankDisplay + SendDisplay -> BT.modify $ set displayBox BlankDisplay SyncDisplay -> BT.modify $ set displayBox BlankDisplay BlankDisplay -> do case s ^. dialogBox of @@ -756,6 +849,71 @@ appEvent (BT.VtyEvent e) = do s ^. inputForm BT.modify $ set dialogBox AName ev -> BT.zoom accounts $ L.handleListEvent ev + SendTx -> do + case e of + V.EvKey V.KEsc [] -> BT.modify $ set dialogBox Blank + V.EvKey V.KEnter [] -> do + if allFieldsValid (s ^. txForm) + then do + pool <- + liftIO $ runNoLoggingT $ initPool $ s ^. dbPath + selWal <- + 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 + selAcc <- + do case L.listSelectedElement $ s ^. accounts of + Nothing -> do + let fAcc = + L.listSelectedElement $ + L.listMoveToBeginning $ + s ^. accounts + case fAcc of + Nothing -> + throw $ + userError "Failed to select wallet" + Just (_j, w1) -> return w1 + Just (_k, w) -> return w + fs1 <- BT.zoom txForm $ BT.gets formState + bl <- + liftIO $ getLastSyncBlock pool $ entityKey selWal + _ <- + liftIO $ + forkIO $ + sendTransaction + pool + (s ^. eventDispatch) + (s ^. zebraHost) + (s ^. zebraPort) + (s ^. network) + (entityKey selAcc) + bl + (fs1 ^. sendAmt) + (fs1 ^. sendTo) + (fs1 ^. sendMemo) + BT.modify $ set msg "Preparing transaction..." + BT.modify $ set displayBox SendDisplay + BT.modify $ set dialogBox Blank + else do + BT.modify $ set msg "Invalid inputs" + BT.modify $ set displayBox MsgDisplay + BT.modify $ set dialogBox Blank + ev -> do + BT.zoom txForm $ do + handleFormEvent (BT.VtyEvent ev) + fs <- BT.gets formState + BT.modify $ + setFieldValid + (isRecipientValid (fs ^. sendTo)) + RecField Blank -> do case e of V.EvKey (V.KChar '\t') [] -> focusRing %= F.focusNext @@ -774,6 +932,11 @@ 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 txForm $ + mkSendForm (s ^. balance) (SendInput "" 0.0 "") + BT.modify $ set dialogBox SendTx ev -> case r of Just AList -> @@ -798,6 +961,9 @@ theMap = , (titleAttr, V.withStyle (fg V.brightGreen) V.bold) , (blinkAttr, style V.blink) , (focusedFormInputAttr, V.white `on` V.blue) + , (invalidFormInputAttr, V.red `on` V.black) + , (E.editAttr, V.white `on` V.blue) + , (E.editFocusedAttr, V.blue `on` V.white) , (baseAttr, bg V.brightBlack) , (barDoneAttr, V.white `on` V.blue) , (barToDoAttr, V.white `on` V.black) @@ -885,6 +1051,7 @@ runZenithCLI config = do 1.0 eventChan 0 + (mkSendForm 0 $ SendInput "" 0.0 "") Left e -> do print $ "No Zebra node available on port " <> @@ -1063,3 +1230,51 @@ addNewAddress n scope s = do T.unpack n ++ "(" ++ T.unpack (showAddress $ walletAddressUAddress $ entityVal x) ++ ")" + +sendTransaction :: + ConnectionPool + -> BC.BChan Tick + -> T.Text + -> Int + -> ZcashNet + -> ZcashAccountId + -> Int + -> Float + -> T.Text + -> T.Text + -> IO () +sendTransaction pool chan zHost zPort znet accId bl amt ua memo = do + BC.writeBChan chan $ TickMsg "Preparing transaction..." + outUA <- parseAddress ua + res <- + runFileLoggingT "zenith.log" $ + prepareTx pool zHost zPort znet accId bl amt outUA memo + BC.writeBChan chan $ TickMsg "Transaction ready, sending to Zebra..." + case res of + Left e -> BC.writeBChan chan $ TickMsg $ show e + Right rawTx -> do + resp <- + makeZebraCall + zHost + zPort + "sendrawtransaction" + [Data.Aeson.String $ toText rawTx] + case resp of + Left e1 -> BC.writeBChan chan $ TickMsg $ "Zebra error: " ++ show e1 + Right txId -> BC.writeBChan chan $ TickMsg $ "Tx ID: " ++ txId + where + parseAddress :: T.Text -> IO UnifiedAddress + parseAddress a = + case isValidUnifiedAddress (E.encodeUtf8 a) of + Just a1 -> return a1 + Nothing -> + case decodeSaplingAddress (E.encodeUtf8 a) of + Just a2 -> + return $ + UnifiedAddress znet Nothing (Just $ sa_receiver a2) Nothing + Nothing -> + case decodeTransparentAddress (E.encodeUtf8 a) of + Just a3 -> + return $ + UnifiedAddress znet Nothing Nothing (Just $ ta_receiver a3) + Nothing -> throwIO $ userError "Incorrect address" diff --git a/src/Zenith/Core.hs b/src/Zenith/Core.hs index 8122f5a..a8dc6f2 100644 --- a/src/Zenith/Core.hs +++ b/src/Zenith/Core.hs @@ -10,6 +10,8 @@ import Control.Monad.Logger ( LoggingT , MonadLoggerIO , NoLoggingT + , logDebugN + , logErrorN , logInfoN , logWarnN , runFileLoggingT @@ -18,6 +20,7 @@ import Control.Monad.Logger ) import Crypto.Secp256k1 (SecKey(..)) import Data.Aeson +import Data.Binary.Get hiding (getBytes) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.Digest.Pure.MD5 @@ -442,17 +445,17 @@ calculateTxFee (t, s, o) i = (5000 * (max (length t) tout + max (length s) sout + length o + oout)) where tout = - if i == 1 + if i == 1 || i == 2 then 1 else 0 sout = - if i == 2 + if i == 3 then 1 else 0 oout = - if i == 3 - then 2 - else 1 + if i == 4 + then 1 + else 0 -- | Prepare a transaction for sending prepareTx :: @@ -465,9 +468,9 @@ prepareTx :: -> Float -> UnifiedAddress -> T.Text - -> IO (Either TxError HexString) + -> LoggingT IO (Either TxError HexString) prepareTx pool zebraHost zebraPort zn za bh amt ua memo = do - accRead <- getAccountById pool za + accRead <- liftIO $ getAccountById pool za let recipient = case o_rec ua of Nothing -> @@ -481,63 +484,97 @@ prepareTx pool zebraHost zebraPort zn za bh amt ua memo = do P2SH -> (2, toBytes $ tr_bytes r3) Just r2 -> (3, getBytes r2) Just r1 -> (4, getBytes r1) - print recipient - trees <- getCommitmentTrees zebraHost zebraPort bh + logDebugN $ T.pack $ show recipient + logDebugN $ T.pack $ "Target block: " ++ show bh + trees <- liftIO $ getCommitmentTrees zebraHost zebraPort bh let sT = SaplingCommitmentTree $ ztiSapling trees let oT = OrchardCommitmentTree $ ztiOrchard trees case accRead of - Nothing -> throwIO $ userError "Can't find Account" + Nothing -> do + logErrorN "Can't find Account" + return $ Left ZHError Just acc -> do - print acc - spParams <- BS.readFile "sapling-spend.params" - outParams <- BS.readFile "sapling-output.params" + logDebugN $ T.pack $ show acc + spParams <- liftIO $ BS.readFile "sapling-spend.params" + outParams <- liftIO $ BS.readFile "sapling-output.params" if show (md5 $ LBS.fromStrict spParams) /= "0f44c12ef115ae019decf18ade583b20" - then throwIO $ userError "Can't validate sapling parameters" - else print "Valid Sapling spend params" + then logErrorN "Can't validate sapling parameters" + else logInfoN "Valid Sapling spend params" if show (md5 $ LBS.fromStrict outParams) /= "924daf81b87a81bbbb9c7d18562046c8" - then throwIO $ userError "Can't validate sapling parameters" - else print "Valid Sapling output params" - print $ BS.length spParams - print $ BS.length outParams - print "Read Sapling params" + then logErrorN "Can't validate sapling parameters" + else logInfoN "Valid Sapling output params" + --print $ BS.length spParams + --print $ BS.length outParams + logDebugN "Read Sapling params" let zats = fromIntegral $ floorFloatInteger $ amt * (10 ^ 8) - firstPass <- selectUnspentNotes pool za zats - let fee = calculateTxFee firstPass 3 - print "calculated fee" - print fee - (tList, sList, oList) <- selectUnspentNotes pool za (zats + fee) - print "selected notes" - print tList - print sList - print oList + logDebugN $ T.pack $ show zats + {-firstPass <- liftIO $ selectUnspentNotes pool za zats-} + --let fee = calculateTxFee firstPass $ fst recipient + --logDebugN $ T.pack $ "calculated fee " ++ show fee + (tList, sList, oList) <- liftIO $ selectUnspentNotes pool za (zats + 5000) + logDebugN "selected notes" + logDebugN $ T.pack $ show tList + logDebugN $ T.pack $ show sList + logDebugN $ T.pack $ show oList let noteTotal = getTotalAmount (tList, sList, oList) - print noteTotal tSpends <- + liftIO $ prepTSpends (getTranSK $ zcashAccountTPrivateKey $ entityVal acc) tList - print tSpends + --print tSpends sSpends <- + liftIO $ prepSSpends (getSapSK $ zcashAccountSapSpendKey $ entityVal acc) sList - print sSpends + --print sSpends oSpends <- + liftIO $ prepOSpends (getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc) oList - print oSpends - outgoing <- makeOutgoing acc recipient zats (noteTotal - fee - zats) - print outgoing - let tx = + --print oSpends + dummy <- + liftIO $ makeOutgoing acc recipient zats (noteTotal - 5000 - zats) + logDebugN "Calculating fee" + let feeResponse = createTransaction (Just sT) (Just oT) tSpends sSpends oSpends - outgoing + dummy (SaplingSpendParams spParams) (SaplingOutputParams outParams) zn (bh + 3) - return tx + False + case feeResponse of + Left e1 -> return $ Left Fee + Right fee -> do + let feeAmt = + fromIntegral (runGet getInt64le $ LBS.fromStrict $ toBytes fee) + (tList1, sList1, oList1) <- + liftIO $ selectUnspentNotes pool za (zats + feeAmt) + logDebugN $ T.pack $ "selected notes with fee" ++ show feeAmt + logDebugN $ T.pack $ show tList + logDebugN $ T.pack $ show sList + logDebugN $ T.pack $ show oList + outgoing <- + liftIO $ makeOutgoing acc recipient zats (noteTotal - feeAmt - zats) + logDebugN $ T.pack $ show outgoing + let tx = + createTransaction + (Just sT) + (Just oT) + tSpends + sSpends + oSpends + outgoing + (SaplingSpendParams spParams) + (SaplingOutputParams outParams) + zn + (bh + 3) + True + return tx where makeOutgoing :: Entity ZcashAccount @@ -587,7 +624,6 @@ prepareTx pool zebraHost zebraPort zn za bh amt ua memo = do prepTSpends sk notes = do forM notes $ \n -> do tAddRead <- getAddressById pool $ walletTrNoteAddress $ entityVal n - print n case tAddRead of Nothing -> throwIO $ userError "Couldn't read t-address" Just tAdd -> do @@ -614,7 +650,6 @@ prepareTx pool zebraHost zebraPort zn za bh amt ua memo = do SaplingSpendingKey -> [Entity WalletSapNote] -> IO [SaplingTxSpend] prepSSpends sk notes = do forM notes $ \n -> do - print n return $ SaplingTxSpend (getBytes sk) @@ -630,7 +665,6 @@ prepareTx pool zebraHost zebraPort zn za bh amt ua memo = do OrchardSpendingKey -> [Entity WalletOrchNote] -> IO [OrchardTxSpend] prepOSpends sk notes = do forM notes $ \n -> do - print n return $ OrchardTxSpend (getBytes sk) diff --git a/src/Zenith/DB.hs b/src/Zenith/DB.hs index 67d9527..a48151d 100644 --- a/src/Zenith/DB.hs +++ b/src/Zenith/DB.hs @@ -119,7 +119,7 @@ share deriving Show Eq UserTx hex HexStringDB - address WalletAddressId + address WalletAddressId OnDeleteCascade OnUpdateCascade time Int amount Int memo T.Text @@ -127,8 +127,8 @@ share deriving Show Eq WalletTrNote tx WalletTransactionId OnDeleteCascade OnUpdateCascade - accId ZcashAccountId - address WalletAddressId + accId ZcashAccountId OnDeleteCascade OnUpdateCascade + address WalletAddressId OnDeleteCascade OnUpdateCascade value Word64 spent Bool script BS.ByteString @@ -138,13 +138,14 @@ share deriving Show Eq WalletTrSpend tx WalletTransactionId OnDeleteCascade OnUpdateCascade - note WalletTrNoteId - accId ZcashAccountId + note WalletTrNoteId OnDeleteCascade OnUpdateCascade + accId ZcashAccountId OnDeleteCascade OnUpdateCascade value Word64 + UniqueTrSpend tx accId deriving Show Eq WalletSapNote tx WalletTransactionId OnDeleteCascade OnUpdateCascade - accId ZcashAccountId + accId ZcashAccountId OnDeleteCascade OnUpdateCascade value Word64 recipient BS.ByteString memo T.Text @@ -159,13 +160,14 @@ share deriving Show Eq WalletSapSpend tx WalletTransactionId OnDeleteCascade OnUpdateCascade - note WalletSapNoteId - accId ZcashAccountId + note WalletSapNoteId OnDeleteCascade OnUpdateCascade + accId ZcashAccountId OnDeleteCascade OnUpdateCascade value Word64 + UniqueSapSepnd tx accId deriving Show Eq WalletOrchNote tx WalletTransactionId OnDeleteCascade OnUpdateCascade - accId ZcashAccountId + accId ZcashAccountId OnDeleteCascade OnUpdateCascade value Word64 recipient BS.ByteString memo T.Text @@ -181,9 +183,10 @@ share deriving Show Eq WalletOrchSpend tx WalletTransactionId OnDeleteCascade OnUpdateCascade - note WalletOrchNoteId - accId ZcashAccountId + note WalletOrchNoteId OnDeleteCascade OnUpdateCascade + accId ZcashAccountId OnDeleteCascade OnUpdateCascade value Word64 + UniqueOrchSpend tx accId deriving Show Eq ZcashTransaction block Int @@ -579,6 +582,20 @@ getMinBirthdayHeight pool = do Nothing -> return 0 Just x -> return $ zcashWalletBirthdayHeight $ entityVal x +getLastSyncBlock :: ConnectionPool -> ZcashWalletId -> IO Int +getLastSyncBlock pool zw = do + b <- + runNoLoggingT $ + PS.retryOnBusy $ + flip PS.runSqlPool pool $ do + selectOne $ do + w <- from $ table @ZcashWallet + where_ (w ^. ZcashWalletId ==. val zw) + pure w + case b of + Nothing -> throwIO $ userError "Failed to retrieve wallet" + Just x -> return $ zcashWalletLastSync $ entityVal x + -- | Save a @WalletTransaction@ saveWalletTransaction :: ConnectionPool @@ -1083,12 +1100,15 @@ findTransparentSpends pool za = do set w [WalletTrNoteSpent =. val True] where_ $ w ^. WalletTrNoteId ==. val (entityKey n) t' <- upsertWalTx (entityVal $ fst $ head s) za - insert_ $ - WalletTrSpend - (entityKey t') - (entityKey n) - za - (walletTrNoteValue $ entityVal n) + _ <- + upsert + (WalletTrSpend + (entityKey t') + (entityKey n) + za + (walletTrNoteValue $ entityVal n)) + [] + return () getWalletSapNotes :: ConnectionPool -> ZcashAccountId -> IO [Entity WalletSapNote] @@ -1130,12 +1150,15 @@ findSapSpends pool za (n:notes) = do set w [WalletSapNoteSpent =. val True] where_ $ w ^. WalletSapNoteId ==. val (entityKey n) t' <- upsertWalTx (entityVal $ fst $ head s) za - insert_ $ - WalletSapSpend - (entityKey t') - (entityKey n) - za - (walletSapNoteValue $ entityVal n) + _ <- + upsert + (WalletSapSpend + (entityKey t') + (entityKey n) + za + (walletSapNoteValue $ entityVal n)) + [] + return () findSapSpends pool za notes getWalletOrchNotes :: @@ -1275,12 +1298,15 @@ findOrchSpends pool za (n:notes) = do set w [WalletOrchNoteSpent =. val True] where_ $ w ^. WalletOrchNoteId ==. val (entityKey n) t' <- upsertWalTx (entityVal $ fst $ head s) za - insert_ $ - WalletOrchSpend - (entityKey t') - (entityKey n) - za - (walletOrchNoteValue $ entityVal n) + _ <- + upsert + (WalletOrchSpend + (entityKey t') + (entityKey n) + za + (walletOrchNoteValue $ entityVal n)) + [] + return () findOrchSpends pool za notes upsertWalTx :: @@ -1316,6 +1342,9 @@ clearWalletTransactions pool = do runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do + delete $ do + _ <- from $ table @UserTx + return () delete $ do _ <- from $ table @WalletOrchSpend return () @@ -1337,9 +1366,6 @@ clearWalletTransactions pool = do delete $ do _ <- from $ table @WalletTransaction return () - delete $ do - _ <- from $ table @UserTx - return () getWalletUnspentTrNotes :: ConnectionPool -> ZcashAccountId -> IO [Entity WalletTrNote] diff --git a/src/Zenith/Utils.hs b/src/Zenith/Utils.hs index 0f013e8..96ca8dd 100644 --- a/src/Zenith/Utils.hs +++ b/src/Zenith/Utils.hs @@ -26,17 +26,17 @@ jsonNumber i = Number $ scientific (fromIntegral i) 0 -- | Helper function to display small amounts of ZEC displayZec :: Integer -> String displayZec s - | s < 100 = show s ++ " zats " - | s < 100000 = show (fromIntegral s / 100) ++ " μZEC " - | s < 100000000 = show (fromIntegral s / 100000) ++ " mZEC " + | abs s < 100 = show s ++ " zats " + | abs s < 100000 = show (fromIntegral s / 100) ++ " μZEC " + | abs s < 100000000 = show (fromIntegral s / 100000) ++ " mZEC " | otherwise = show (fromIntegral s / 100000000) ++ " ZEC " -- | Helper function to display small amounts of ZEC displayTaz :: Integer -> String displayTaz s - | s < 100 = show s ++ " tazs " - | s < 100000 = show (fromIntegral s / 100) ++ " μTAZ " - | s < 100000000 = show (fromIntegral s / 100000) ++ " mTAZ " + | abs s < 100 = show s ++ " tazs " + | abs s < 100000 = show (fromIntegral s / 100) ++ " μTAZ " + | abs s < 100000000 = show (fromIntegral s / 100000) ++ " mTAZ " | otherwise = show (fromIntegral s / 100000000) ++ " TAZ " -- | Helper function to display abbreviated Unified Address diff --git a/test/Spec.hs b/test/Spec.hs index 941ada8..35fb3a1 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,7 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} import Control.Monad (when) +import Control.Monad.Logger (runNoLoggingT) import Data.HexString +import qualified Data.Text.Encoding as E import Database.Persist import Database.Persist.Sqlite import System.Directory @@ -10,15 +12,22 @@ import Test.Hspec import ZcashHaskell.Orchard (isValidUnifiedAddress) import ZcashHaskell.Sapling ( decodeSaplingOutputEsk + , encodeSaplingAddress , getSaplingNotePosition , getSaplingWitness + , isValidShieldedAddress , updateSaplingCommitmentTree ) +import ZcashHaskell.Transparent + ( decodeExchangeAddress + , decodeTransparentAddress + ) import ZcashHaskell.Types ( DecodedNote(..) , OrchardSpendingKey(..) , Phrase(..) , SaplingCommitmentTree(..) + , SaplingReceiver(..) , SaplingSpendingKey(..) , Scope(..) , ShieldedOutput(..) @@ -72,8 +81,9 @@ main = do "None" `shouldBe` maybe "None" zcashWalletName s describe "Wallet function tests:" $ do it "Save Wallet:" $ do + pool <- runNoLoggingT $ initPool "test.db" zw <- - saveWallet "test.db" $ + saveWallet pool $ ZcashWallet "Testing" (ZcashNetDB MainNet) @@ -84,19 +94,19 @@ main = do 0 zw `shouldNotBe` Nothing it "Save Account:" $ do + pool <- runNoLoggingT $ initPool "test.db" s <- runSqlite "test.db" $ do selectList [ZcashWalletName ==. "Testing"] [] - za <- - saveAccount "test.db" =<< - createZcashAccount "TestAccount" 0 (head s) + za <- saveAccount pool =<< createZcashAccount "TestAccount" 0 (head s) za `shouldNotBe` Nothing it "Save address:" $ do + pool <- runNoLoggingT $ initPool "test.db" acList <- runSqlite "test.db" $ selectList [ZcashAccountName ==. "TestAccount"] [] zAdd <- - saveAddress "test.db" =<< + saveAddress pool =<< createWalletAddress "Personal123" 0 MainNet External (head acList) addList <- runSqlite "test.db" $ @@ -162,29 +172,82 @@ main = do "6c5d1413c63a9a88db71c3f41dc12cd60197ee742fc75b217215e7144db48bd3" describe "Note selection for Tx" $ do it "Value less than balance" $ do - res <- selectUnspentNotes "zenith.db" (toSqlKey 1) 14000000 + pool <- runNoLoggingT $ initPool "zenith.db" + res <- selectUnspentNotes pool (toSqlKey 1) 14000000 res `shouldNotBe` ([], [], []) it "Value greater than balance" $ do - let res = selectUnspentNotes "zenith.db" (toSqlKey 1) 84000000 + pool <- runNoLoggingT $ initPool "zenith.db" + let res = selectUnspentNotes pool (toSqlKey 1) 84000000 res `shouldThrow` anyIOException it "Fee calculation" $ do - res <- selectUnspentNotes "zenith.db" (toSqlKey 1) 14000000 + pool <- runNoLoggingT $ initPool "zenith.db" + res <- selectUnspentNotes pool (toSqlKey 1) 14000000 calculateTxFee res 3 `shouldBe` 20000 - describe "Creating Tx" $ do - xit "To Orchard" $ do - let uaRead = - isValidUnifiedAddress - "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" - case uaRead of - Nothing -> assertFailure "wrong address" - Just ua -> do - tx <- - prepareTx - "zenith.db" - TestNet - (toSqlKey 1) - 2819811 - 0.04 - ua - "sent with Zenith, test" - tx `shouldBe` Right (hexString "deadbeef") + describe "Testing validation" $ do + it "Unified" $ do + let a = + "utest1zfnw84xuxg0ytzqc008gz0qntr8cvwu4qjsccgtxwdrjywra7uj85x8ldymjc2jd3jvvvhyj3xwsunyvwkr5084t6p5gmvzwdgvwpflrpd6a3squ2dp8vt7cxngmwk30l44wkmvyfegypqmezxfnqj572lr779gkqj5xekp66uv4jga58alnc5j7tuank758zd96ap4f09udg6y6pxu" + True `shouldBe` + (case isValidUnifiedAddress (E.encodeUtf8 a) of + Just _a1 -> True + Nothing -> + isValidShieldedAddress (E.encodeUtf8 a) || + (case decodeTransparentAddress (E.encodeUtf8 a) of + Just _a3 -> True + Nothing -> + case decodeExchangeAddress a of + Just _a4 -> True + Nothing -> False)) + it "Sapling" $ do + let a = + "ztestsapling1tgjr4zppwk4ne8xy6gdq4z2gwq7dmf5jq8z2ctpn8nlmtse0a74fa5z0m8z383gmpgqz6q6duu4" + True `shouldBe` + (case isValidUnifiedAddress (E.encodeUtf8 a) of + Just _a1 -> True + Nothing -> + isValidShieldedAddress (E.encodeUtf8 a) || + (case decodeTransparentAddress (E.encodeUtf8 a) of + Just _a3 -> True + Nothing -> + case decodeExchangeAddress a of + Just _a4 -> True + Nothing -> False)) + it "Transparent" $ do + let a = "tmGfVZHuGVJ5vcLAgBdkUU4w7fLTRE5nXm3" + True `shouldBe` + (case isValidUnifiedAddress (E.encodeUtf8 a) of + Just _a1 -> True + Nothing -> + isValidShieldedAddress (E.encodeUtf8 a) || + (case decodeTransparentAddress (E.encodeUtf8 a) of + Just _a3 -> True + Nothing -> + case decodeExchangeAddress a of + Just _a4 -> True + Nothing -> False)) + it "Check Sapling Address" $ do + let a = + encodeSaplingAddress TestNet $ + SaplingReceiver + "Z$:\136!u\171<\156\196\210\SUB\n\137Hp<\221\166\146\SOH\196\172,3<\255\181\195/\239\170\158\208O\217\197\DC3\197\ESC\n\NUL-" + a `shouldBe` + Just + "ztestsapling1tgjr4zppwk4ne8xy6gdq4z2gwq7dmf5jq8z2ctpn8nlmtse0a74fa5z0m8z383gmpgqz6q6duu4" + {-describe "Creating Tx" $ do-} + {-xit "To Orchard" $ do-} + {-let uaRead =-} + {-isValidUnifiedAddress-} + {-"utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax"-} + {-case uaRead of-} + {-Nothing -> assertFailure "wrong address"-} + {-Just ua -> do-} + {-tx <--} + {-prepareTx-} + {-"zenith.db"-} + {-TestNet-} + {-(toSqlKey 1)-} + {-2819811-} + {-0.04-} + {-ua-} + {-"sent with Zenith, test"-} + {-tx `shouldBe` Right (hexString "deadbeef")-} diff --git a/zcash-haskell b/zcash-haskell index 22c0fe3..9dddb42 160000 --- a/zcash-haskell +++ b/zcash-haskell @@ -1 +1 @@ -Subproject commit 22c0fe374976d9f2323a8b7cd42f941423d45111 +Subproject commit 9dddb42bb3ab78ed0c4d44efb00960ac112c2ce6 diff --git a/zenith.cabal b/zenith.cabal index 41d11ff..12e0b6c 100644 --- a/zenith.cabal +++ b/zenith.cabal @@ -46,6 +46,7 @@ library , bytestring , esqueleto , resource-pool + , binary , exceptions , monad-logger , vty-crossplatform @@ -122,6 +123,7 @@ test-suite zenith-tests base >=4.12 && <5 , bytestring , configurator + , monad-logger , data-default , sort , text