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