Implement background sync

Merge pull request 'Implement transaction creation' (#77 ) from rav001 into dev041
Reviewed-on: #77
2024-05-05 09:49:55 -05:00 · 2024-05-03 12:15:11 +00:00
7 changed files with 916 additions and 687 deletions
--- 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

--- 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
--- 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
+  pool <- liftIO $ runNoLoggingT $ initPool $ s ^. dbPath
+  case t of
+    TickMsg m -> do
+      BT.modify $ set msg m
+      BT.modify $ set displayBox MsgDisplay
+    TickVal v -> do
      case s ^. displayBox of
+        AddrDisplay -> return ()
+        MsgDisplay -> return ()
+        PhraseDisplay -> return ()
+        TxDisplay -> return ()
        SyncDisplay -> do
          if s ^. barValue == 1.0
-        then BT.modify $ set displayBox BlankDisplay
-        else BT.modify $ set displayBox SyncDisplay
-    _ -> return ()
+            then do
+              selWallet <-
+                do case L.listSelectedElement $ s ^. wallets of
+                     Nothing -> do
+                       let fWall =
+                             L.listSelectedElement $
+                             L.listMoveToBeginning $ s ^. wallets
+                       case fWall of
+                         Nothing -> throw $ userError "Failed to select wallet"
+                         Just (_j, w1) -> return w1
+                     Just (_k, w) -> return w
+              _ <-
+                liftIO $
+                syncWallet
+                  (Config (s ^. dbPath) (s ^. zebraHost) (s ^. zebraPort))
+                  selWallet
+              BT.modify $ set displayBox BlankDisplay
+              BT.modify $ set barValue 0.0
+              updatedState <- BT.get
+              ns <- liftIO $ refreshWallet updatedState
+              BT.put ns
+            else BT.modify $ set barValue $ validBarValue (v + s ^. barValue)
+        BlankDisplay -> do
+          case s ^. dialogBox of
+            AName -> return ()
+            AdName -> return ()
+            WName -> return ()
+            WSelect -> return ()
+            ASelect -> return ()
+            Blank -> do
+              if s ^. timer == 90
+                then do
+                  BT.modify $ set barValue 0.0
+                  BT.modify $ set displayBox SyncDisplay
+                  sBlock <- liftIO $ getMinBirthdayHeight pool
+                  _ <-
+                    liftIO $
+                    forkIO $
+                    scanZebra
+                      (s ^. dbPath)
+                      (s ^. zebraHost)
+                      (s ^. zebraPort)
+                      sBlock
+                      (s ^. eventDispatch)
+                  BT.modify $ set timer 0
+                  return ()
+                else do
+                  BT.modify $ set timer $ 1 + s ^. timer
 appEvent (BT.VtyEvent e) = do
  r <- F.focusGetCurrent <$> use focusRing
  s <- BT.get
@ -565,33 +632,47 @@ appEvent (BT.VtyEvent e) = do
               _ev -> return ()
           else do
             case s ^. displayBox of
-               AddrDisplay -> BT.modify $ set displayBox BlankDisplay
+               AddrDisplay -> do
+                 case e of
+                   V.EvKey (V.KChar 'x') [] ->
+                     BT.modify $ set displayBox BlankDisplay
+                   V.EvKey (V.KChar 'u') [] -> do
+                     case L.listSelectedElement $ s ^. addresses of
+                       Just (_, a) -> do
+                         liftIO $
+                           setClipboard $
+                           T.unpack $
+                           getUA $ walletAddressUAddress $ entityVal a
+                       Nothing -> return ()
+                   V.EvKey (V.KChar 's') [] -> do
+                     case L.listSelectedElement $ s ^. addresses of
+                       Just (_, a) -> do
+                         liftIO $
+                           setClipboard $
+                           maybe "None" T.unpack $
+                           getSaplingFromUA $
+                           E.encodeUtf8 $
+                           getUA $ walletAddressUAddress $ entityVal a
+                       Nothing -> return ()
+                   V.EvKey (V.KChar 't') [] -> do
+                     case L.listSelectedElement $ s ^. addresses of
+                       Just (_, a) -> do
+                         liftIO $
+                           setClipboard $
+                           T.unpack $
+                           maybe
+                             "None"
+                             (encodeTransparentReceiver (s ^. network)) $
+                           t_rec =<<
+                           (isValidUnifiedAddress .
+                            E.encodeUtf8 . getUA . walletAddressUAddress)
+                             (entityVal a)
+                       Nothing -> return ()
+                   _ev -> return ()
               MsgDisplay -> BT.modify $ set displayBox BlankDisplay
               PhraseDisplay -> BT.modify $ set displayBox BlankDisplay
               TxDisplay -> BT.modify $ set displayBox BlankDisplay
-               SyncDisplay -> do
-                 if s ^. barValue == 1.0
-                   then BT.modify $ set displayBox BlankDisplay
-                   else do
-                     sBlock <- liftIO $ getMinBirthdayHeight $ s ^. dbPath
-                     selWallet <-
-                       do case L.listSelectedElement $ s ^. wallets of
-                            Nothing -> do
-                              let fWall =
-                                    L.listSelectedElement $
-                                    L.listMoveToBeginning $ s ^. wallets
-                              case fWall of
-                                Nothing ->
-                                  throw $ userError "Failed to select wallet"
-                                Just (_j, w1) -> return w1
-                            Just (_k, w) -> return w
-                     scanZebra sBlock
-                     liftIO $
-                       runFileLoggingT "zenith.log" $
-                       syncWallet
-                         (Config (s ^. dbPath) (s ^. zebraHost) (s ^. zebraPort))
-                         selWallet
-                     BT.modify $ set displayBox SyncDisplay
+               SyncDisplay -> BT.modify $ set displayBox BlankDisplay
               BlankDisplay -> do
                 case s ^. dialogBox of
                   WName -> do
@ -693,9 +774,6 @@ appEvent (BT.VtyEvent e) = do
                         BT.modify $ set displayBox TxDisplay
                       V.EvKey (V.KChar 'a') [] ->
                         BT.modify $ set dialogBox ASelect
-                       V.EvKey (V.KChar 's') [] -> do
-                         BT.modify $ set barValue 0.0
-                         BT.modify $ set displayBox SyncDisplay
                       ev ->
                         case r of
                           Just AList ->
@ -740,6 +818,7 @@ runZenithCLI config = do
  let host = c_zebraHost config
  let port = c_zebraPort config
  let dbFilePath = c_dbPath config
+  pool <- runNoLoggingT $ initPool dbFilePath
  w <- try $ checkZebra host port :: IO (Either IOError ZebraGetInfo)
  case w of
    Right zebra -> do
@ -750,18 +829,18 @@ runZenithCLI config = do
        Left e1 -> throwIO e1
        Right chainInfo -> do
          initDb dbFilePath
-          walList <- getWallets dbFilePath $ zgb_net chainInfo
+          walList <- getWallets pool $ zgb_net chainInfo
          accList <-
            if not (null walList)
-              then getAccounts dbFilePath $ entityKey $ head walList
+              then runNoLoggingT $ getAccounts pool $ entityKey $ head walList
              else return []
          addrList <-
            if not (null accList)
-              then getAddresses dbFilePath $ entityKey $ head accList
+              then runNoLoggingT $ getAddresses pool $ entityKey $ head accList
              else return []
          txList <-
            if not (null addrList)
-              then getUserTx dbFilePath $ entityKey $ head addrList
+              then getUserTx pool $ entityKey $ head addrList
              else return []
          let block =
                if not (null walList)
@ -769,9 +848,14 @@ runZenithCLI config = do
                  else 0
          bal <-
            if not (null accList)
-              then getBalance dbFilePath $ entityKey $ head accList
+              then getBalance pool $ entityKey $ head accList
              else return 0
          eventChan <- BC.newBChan 10
+          _ <-
+            forkIO $
+            forever $ do
+              BC.writeBChan eventChan (TickVal 0.0)
+              threadDelay 1000000
          let buildVty = VC.mkVty V.defaultConfig
          initialVty <- buildVty
          void $
@ -800,6 +884,7 @@ runZenithCLI config = do
              bal
              1.0
              eventChan
+              0
    Left e -> do
      print $
        "No Zebra node available on port " <>
@ -807,34 +892,38 @@ runZenithCLI config = do

 refreshWallet :: State -> IO State
 refreshWallet s = do
-  selWallet <-
+  pool <- runNoLoggingT $ initPool $ s ^. dbPath
+  walList <- getWallets pool $ s ^. network
+  (ix, selWallet) <-
    do case L.listSelectedElement $ s ^. wallets of
         Nothing -> do
           let fWall =
                 L.listSelectedElement $ L.listMoveToBeginning $ s ^. wallets
           case fWall of
             Nothing -> throw $ userError "Failed to select wallet"
-             Just (_j, w1) -> return w1
-         Just (_k, w) -> return w
-  aL <- getAccounts (s ^. dbPath) $ entityKey selWallet
+             Just (j, w1) -> return (j, w1)
+         Just (k, w) -> return (k, w)
+  aL <- runNoLoggingT $ getAccounts pool $ entityKey selWallet
  let bl = zcashWalletLastSync $ entityVal selWallet
  addrL <-
    if not (null aL)
-      then getAddresses (s ^. dbPath) $ entityKey $ head aL
+      then runNoLoggingT $ getAddresses pool $ entityKey $ head aL
      else return []
  bal <-
    if not (null aL)
-      then getBalance (s ^. dbPath) $ entityKey $ head aL
+      then getBalance pool $ entityKey $ head aL
      else return 0
  txL <-
    if not (null addrL)
-      then getUserTx (s ^. dbPath) $ entityKey $ head addrL
+      then getUserTx pool $ entityKey $ head addrL
      else return []
+  let wL = L.listReplace (Vec.fromList walList) (Just ix) (s ^. wallets)
  let aL' = L.listReplace (Vec.fromList aL) (Just 0) (s ^. accounts)
  let addrL' = L.listReplace (Vec.fromList addrL) (Just 0) (s ^. addresses)
  let txL' = L.listReplace (Vec.fromList txL) (Just 0) (s ^. transactions)
  return $
-    (s & accounts .~ aL') & syncBlock .~ bl & balance .~ bal & addresses .~
+    s & wallets .~ wL & accounts .~ aL' & syncBlock .~ bl & balance .~ bal &
+    addresses .~
    addrL' &
    transactions .~
    txL' &
@ -845,16 +934,15 @@ refreshWallet s = do
 addNewWallet :: T.Text -> State -> IO State
 addNewWallet n s = do
  sP <- generateWalletSeedPhrase
+  pool <- runNoLoggingT $ initPool $ s ^. dbPath
  let bH = s ^. startBlock
  let netName = s ^. network
-  r <-
-    saveWallet (s ^. dbPath) $
-    ZcashWallet n (ZcashNetDB netName) (PhraseDB sP) bH 0
+  r <- saveWallet pool $ ZcashWallet n (ZcashNetDB netName) (PhraseDB sP) bH 0
  case r of
    Nothing -> do
      return $ s & msg .~ ("Wallet already exists: " ++ T.unpack n)
    Just _ -> do
-      wL <- getWallets (s ^. dbPath) netName
+      wL <- getWallets pool netName
      let aL =
            L.listFindBy (\x -> zcashWalletName (entityVal x) == n) $
            L.listReplace (Vec.fromList wL) (Just 0) (s ^. wallets)
@ -862,6 +950,7 @@ addNewWallet n s = do

 addNewAccount :: T.Text -> State -> IO State
 addNewAccount n s = do
+  pool <- runNoLoggingT $ initPool $ s ^. dbPath
  selWallet <-
    do case L.listSelectedElement $ s ^. wallets of
         Nothing -> do
@ -871,19 +960,19 @@ addNewAccount n s = do
             Nothing -> throw $ userError "Failed to select wallet"
             Just (_j, w1) -> return w1
         Just (_k, w) -> return w
-  aL' <- getMaxAccount (s ^. dbPath) (entityKey selWallet)
+  aL' <- getMaxAccount pool (entityKey selWallet)
  zA <-
    try $ createZcashAccount n (aL' + 1) selWallet :: IO
      (Either IOError ZcashAccount)
  case zA of
    Left e -> return $ s & msg .~ ("Error: " ++ show e)
    Right zA' -> do
-      r <- saveAccount (s ^. dbPath) zA'
+      r <- saveAccount pool zA'
      case r of
        Nothing ->
          return $ s & msg .~ ("Account already exists: " ++ T.unpack n)
        Just x -> do
-          aL <- getAccounts (s ^. dbPath) (entityKey selWallet)
+          aL <- runNoLoggingT $ getAccounts pool (entityKey selWallet)
          let nL =
                L.listMoveToElement x $
                L.listReplace (Vec.fromList aL) (Just 0) (s ^. accounts)
@ -892,6 +981,7 @@ addNewAccount n s = do

 refreshAccount :: State -> IO State
 refreshAccount s = do
+  pool <- runNoLoggingT $ initPool $ s ^. dbPath
  selAccount <-
    do case L.listSelectedElement $ s ^. accounts of
         Nothing -> do
@ -901,8 +991,8 @@ refreshAccount s = do
             Nothing -> throw $ userError "Failed to select account"
             Just (_j, w1) -> return w1
         Just (_k, w) -> return w
-  aL <- getAddresses (s ^. dbPath) $ entityKey selAccount
-  bal <- getBalance (s ^. dbPath) $ entityKey selAccount
+  aL <- runNoLoggingT $ getAddresses pool $ entityKey selAccount
+  bal <- getBalance pool $ entityKey selAccount
  let aL' = L.listReplace (Vec.fromList aL) (Just 0) (s ^. addresses)
  selAddress <-
    do case L.listSelectedElement aL' of
@ -916,7 +1006,7 @@ refreshAccount s = do
      s & balance .~ bal & addresses .~ aL' & msg .~ "Switched to account: " ++
      T.unpack (zcashAccountName $ entityVal selAccount)
    Just (_i, a) -> do
-      tList <- getUserTx (s ^. dbPath) $ entityKey a
+      tList <- getUserTx pool $ entityKey a
      let tL' = L.listReplace (Vec.fromList tList) (Just 0) (s ^. transactions)
      return $
        s & balance .~ bal & addresses .~ aL' & transactions .~ tL' & msg .~
@ -925,6 +1015,7 @@ refreshAccount s = do

 refreshTxs :: State -> IO State
 refreshTxs s = do
+  pool <- runNoLoggingT $ initPool $ s ^. dbPath
  selAddress <-
    do case L.listSelectedElement $ s ^. addresses of
         Nothing -> do
@ -935,12 +1026,13 @@ refreshTxs s = do
  case selAddress of
    Nothing -> return s
    Just (_i, a) -> do
-      tList <- getUserTx (s ^. dbPath) $ entityKey a
+      tList <- getUserTx pool $ entityKey a
      let tL' = L.listReplace (Vec.fromList tList) (Just 0) (s ^. transactions)
      return $ s & transactions .~ tL'

 addNewAddress :: T.Text -> Scope -> State -> IO State
 addNewAddress n scope s = do
+  pool <- runNoLoggingT $ initPool $ s ^. dbPath
  selAccount <-
    do case L.listSelectedElement $ s ^. accounts of
         Nothing -> do
@ -950,19 +1042,19 @@ addNewAddress n scope s = do
             Nothing -> throw $ userError "Failed to select account"
             Just (_j, a1) -> return a1
         Just (_k, a) -> return a
-  maxAddr <- getMaxAddress (s ^. dbPath) (entityKey selAccount) scope
+  maxAddr <- getMaxAddress pool (entityKey selAccount) scope
  uA <-
    try $ createWalletAddress n (maxAddr + 1) (s ^. network) scope selAccount :: IO
      (Either IOError WalletAddress)
  case uA of
    Left e -> return $ s & msg .~ ("Error: " ++ show e)
    Right uA' -> do
-      nAddr <- saveAddress (s ^. dbPath) uA'
+      nAddr <- saveAddress pool uA'
      case nAddr of
        Nothing ->
          return $ s & msg .~ ("Address already exists: " ++ T.unpack n)
        Just x -> do
-          addrL <- getAddresses (s ^. dbPath) (entityKey selAccount)
+          addrL <- runNoLoggingT $ getAddresses pool (entityKey selAccount)
          let nL =
                L.listMoveToElement x $
                L.listReplace (Vec.fromList addrL) (Just 0) (s ^. addresses)
--- 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,48 +396,34 @@ findOrchardActions config b znet za = do
        (getHex $ orchActionCv $ entityVal o)
        (getHex $ orchActionAuth $ entityVal o)

-updateSaplingWitnesses :: T.Text -> LoggingT IO ()
-updateSaplingWitnesses dbPath = do
-  sapNotes <- liftIO $ getUnspentSapNotes dbPath
-  pool <- createSqlitePool dbPath 5
+updateSaplingWitnesses :: ConnectionPool -> IO ()
+updateSaplingWitnesses pool = do
+  sapNotes <- getUnspentSapNotes pool
  maxId <- liftIO $ getMaxSaplingNote pool
-  mapM_ (updateOneNote pool maxId) sapNotes
+  mapM_ (updateOneNote maxId) sapNotes
  where
-    updateOneNote ::
-         Pool SqlBackend
-      -> ShieldOutputId
-      -> Entity WalletSapNote
-      -> LoggingT IO ()
-    updateOneNote pool maxId n = do
+    updateOneNote :: ShieldOutputId -> Entity WalletSapNote -> IO ()
+    updateOneNote maxId n = do
      let noteSync = walletSapNoteWitPos $ entityVal n
-      if noteSync < maxId
-        then do
-          cmus <-
-            liftIO $ getSaplingCmus pool $ walletSapNoteWitPos $ entityVal n
+      when (noteSync < maxId) $ do
+        cmus <- liftIO $ getSaplingCmus pool $ walletSapNoteWitPos $ entityVal n
        let cmuList = map (\(ESQ.Value x) -> getHex x) cmus
        let newWitness =
              updateSaplingWitness
                (SaplingWitness $ getHex $ walletSapNoteWitness $ entityVal n)
                cmuList
        liftIO $ updateSapNoteRecord pool (entityKey n) newWitness maxId
-        else logInfoN "Witness up to date"

-updateOrchardWitnesses :: T.Text -> LoggingT IO ()
-updateOrchardWitnesses dbPath = do
-  orchNotes <- liftIO $ getUnspentOrchNotes dbPath
-  pool <- createSqlitePool dbPath 5
-  maxId <- liftIO $ getMaxOrchardNote pool
-  mapM_ (updateOneNote pool maxId) orchNotes
+updateOrchardWitnesses :: ConnectionPool -> IO ()
+updateOrchardWitnesses pool = do
+  orchNotes <- getUnspentOrchNotes pool
+  maxId <- getMaxOrchardNote pool
+  mapM_ (updateOneNote maxId) orchNotes
  where
-    updateOneNote ::
-         Pool SqlBackend
-      -> OrchActionId
-      -> Entity WalletOrchNote
-      -> LoggingT IO ()
-    updateOneNote pool maxId n = do
+    updateOneNote :: OrchActionId -> Entity WalletOrchNote -> IO ()
+    updateOneNote maxId n = do
      let noteSync = walletOrchNoteWitPos $ entityVal n
-      if noteSync < maxId
-        then do
+      when (noteSync < maxId) $ do
        cmxs <- liftIO $ getOrchardCmxs pool noteSync
        let cmxList = map (\(ESQ.Value x) -> getHex x) cmxs
        let newWitness =
@ -448,7 +431,6 @@ updateOrchardWitnesses dbPath = do
                (OrchardWitness $ getHex $ walletOrchNoteWitness $ entityVal n)
                cmxList
        liftIO $ updateOrchNoteRecord pool (entityKey n) newWitness maxId
-        else logInfoN "Witness up to date"

 -- | Calculate fee per ZIP-317
 calculateTxFee ::
@ -474,7 +456,7 @@ calculateTxFee (t, s, o) i =

 -- | Prepare a transaction for sending
 prepareTx ::
-     T.Text
+     ConnectionPool
  -> T.Text
  -> Int
  -> ZcashNet
@ -484,8 +466,8 @@ prepareTx ::
  -> UnifiedAddress
  -> T.Text
  -> IO (Either TxError HexString)
-prepareTx dbPath zebraHost zebraPort zn za bh amt ua memo = do
-  accRead <- getAccountById dbPath za
+prepareTx pool zebraHost zebraPort zn za bh amt ua memo = do
+  accRead <- getAccountById pool za
  let recipient =
        case o_rec ua of
          Nothing ->
@ -521,11 +503,11 @@ prepareTx dbPath zebraHost zebraPort zn za bh amt ua memo = do
      print $ BS.length outParams
      print "Read Sapling params"
      let zats = fromIntegral $ floorFloatInteger $ amt * (10 ^ 8)
-      firstPass <- selectUnspentNotes dbPath za zats
+      firstPass <- selectUnspentNotes pool za zats
      let fee = calculateTxFee firstPass 3
      print "calculated fee"
      print fee
-      (tList, sList, oList) <- selectUnspentNotes dbPath za (zats + fee)
+      (tList, sList, oList) <- selectUnspentNotes pool za (zats + fee)
      print "selected notes"
      print tList
      print sList
@ -564,7 +546,7 @@ prepareTx dbPath zebraHost zebraPort zn za bh amt ua memo = do
      -> Integer
      -> IO [OutgoingNote]
    makeOutgoing acc (k, recvr) zats chg = do
-      chgAddr <- getInternalAddresses dbPath $ entityKey acc
+      chgAddr <- runNoLoggingT $ getInternalAddresses pool $ entityKey acc
      let internalUA = getUA $ walletAddressUAddress $ entityVal $ head chgAddr
      let chgRcvr =
            fromJust $ o_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA)
@ -604,7 +586,7 @@ prepareTx dbPath zebraHost zebraPort zn za bh amt ua memo = do
      -> IO [TransparentTxSpend]
    prepTSpends sk notes = do
      forM notes $ \n -> do
-        tAddRead <- getAddressById dbPath $ walletTrNoteAddress $ entityVal n
+        tAddRead <- getAddressById pool $ walletTrNoteAddress $ entityVal n
        print n
        case tAddRead of
          Nothing -> throwIO $ userError "Couldn't read t-address"
@ -614,7 +596,7 @@ prepareTx dbPath zebraHost zebraPort zn za bh amt ua memo = do
                (walletAddressIndex $ entityVal tAdd)
                (getScope $ walletAddressScope $ entityVal tAdd)
                sk
-            mReverseTxId <- getWalletTxId dbPath $ walletTrNoteTx $ entityVal n
+            mReverseTxId <- getWalletTxId pool $ walletTrNoteTx $ entityVal n
            case mReverseTxId of
              Nothing -> throwIO $ userError "failed to get tx ID"
              Just (ESQ.Value reverseTxId) -> do
@ -679,22 +661,24 @@ prepareTx dbPath zebraHost zebraPort zn za bh amt ua memo = do
 syncWallet ::
     Config -- ^ configuration parameters
  -> Entity ZcashWallet
-  -> LoggingT IO ()
+  -> IO ()
 syncWallet config w = do
+  startTime <- liftIO getCurrentTime
  let walletDb = c_dbPath config
-  accs <- liftIO $ getAccounts walletDb $ entityKey w
-  addrs <- liftIO $ concat <$> mapM (getAddresses walletDb . entityKey) accs
+  pool <- runNoLoggingT $ initPool walletDb
+  accs <- runNoLoggingT $ getAccounts pool $ entityKey w
+  addrs <- concat <$> mapM (runNoLoggingT . getAddresses pool . entityKey) accs
  intAddrs <-
-    liftIO $ concat <$> mapM (getInternalAddresses walletDb . entityKey) accs
-  chainTip <- liftIO $ getMaxBlock walletDb
+    concat <$> mapM (runNoLoggingT . getInternalAddresses pool . entityKey) accs
+  chainTip <- runNoLoggingT $ getMaxBlock pool
  let lastBlock = zcashWalletLastSync $ entityVal w
  let startBlock =
        if lastBlock > 0
          then lastBlock
          else zcashWalletBirthdayHeight $ entityVal w
-  mapM_ (liftIO . findTransparentNotes walletDb startBlock) addrs
-  mapM_ (liftIO . findTransparentNotes walletDb startBlock) intAddrs
-  mapM_ (liftIO . findTransparentSpends walletDb . entityKey) accs
+  mapM_ (liftIO . findTransparentNotes pool startBlock) addrs
+  mapM_ (liftIO . findTransparentNotes pool startBlock) intAddrs
+  mapM_ (liftIO . findTransparentSpends pool . entityKey) accs
  sapNotes <-
    liftIO $
    mapM
@ -705,52 +689,52 @@ syncWallet config w = do
    mapM
      (findOrchardActions config startBlock (zcashWalletNetwork $ entityVal w))
      accs
-  _ <- updateSaplingWitnesses walletDb
-  _ <- updateOrchardWitnesses walletDb
-  _ <- liftIO $ updateWalletSync walletDb chainTip (entityKey w)
-  _ <- liftIO $ mapM_ (getWalletTransactions walletDb) addrs
-  logInfoN "Synced wallet"
+  _ <- updateSaplingWitnesses pool
+  _ <- updateOrchardWitnesses pool
+  _ <- liftIO $ updateWalletSync pool chainTip (entityKey w)
+  mapM_ (runNoLoggingT . getWalletTransactions pool) addrs

 testSync :: Config -> IO ()
 testSync config = do
  let dbPath = c_dbPath config
  _ <- initDb dbPath
-  w <- getWallets dbPath TestNet
-  r <- runFileLoggingT "zenith.log" $ mapM (syncWallet config) w
+  pool <- runNoLoggingT $ initPool dbPath
+  w <- getWallets pool TestNet
+  r <- mapM (syncWallet config) w
  liftIO $ print r
+  {-let uaRead =-}
+        {-isValidUnifiedAddress-}
+          {-"utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax"-}
+  {-case uaRead of-}
+    {-Nothing -> print "wrong address"-}
+    {-Just ua -> do-}
+      {-startTime <- getCurrentTime-}
+      {-print startTime-}
+      {-tx <--}
+        {-prepareTx-}
+          {-"zenith.db"-}
+          {-"127.0.0.1"-}
+          {-18232-}
+          {-TestNet-}
+          {-(toSqlKey 1)-}
+          {-2820897-}
+          {-0.04-}
+          {-ua-}
+          {-"sent with Zenith, test"-}
+      {-print tx-}
+      {-endTime <- getCurrentTime-}
+      {-print endTime-}

-testSend :: IO ()
-testSend = do
-  let uaRead =
-        isValidUnifiedAddress
-          "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax"
-  case uaRead of
-    Nothing -> print "wrong address"
-    Just ua -> do
-      startTime <- getCurrentTime
-      print startTime
-      tx <-
-        prepareTx
-          "zenith.db"
-          "127.0.0.1"
-          18232
-          TestNet
-          (toSqlKey 1)
-          2820897
-          0.04
-          ua
-          "sent with Zenith, test"
-      print tx
-      endTime <- getCurrentTime
-      print endTime
-
+{-testSend :: IO ()-}
+{-testSend = do-}
 clearSync :: Config -> IO ()
 clearSync config = do
  let dbPath = c_dbPath config
+  pool <- runNoLoggingT $ initPool dbPath
  _ <- initDb dbPath
-  _ <- clearWalletTransactions dbPath
-  w <- getWallets dbPath TestNet
-  liftIO $ mapM_ (updateWalletSync dbPath 0 . entityKey) w
-  w' <- liftIO $ getWallets dbPath TestNet
-  r <- runFileLoggingT "zenith.log" $ mapM (syncWallet config) w'
+  _ <- clearWalletTransactions pool
+  w <- getWallets pool TestNet
+  liftIO $ mapM_ (updateWalletSync pool 0 . entityKey) w
+  w' <- liftIO $ getWallets pool TestNet
+  r <- mapM (syncWallet config) w'
  liftIO $ print r
--- 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,9 +266,11 @@ upgradeDb dbName = do
  PS.runSqlite dbName $ do runMigrationUnsafe migrateAll

 -- | Get existing wallets from database
-getWallets :: T.Text -> ZcashNet -> IO [Entity ZcashWallet]
-getWallets dbFp n =
-  PS.runSqlite dbFp $
+getWallets :: ConnectionPool -> ZcashNet -> IO [Entity ZcashWallet]
+getWallets pool n =
+  runNoLoggingT $
+  PS.retryOnBusy $
+  flip PS.runSqlPool pool $ do
    select $ do
      wallets <- from $ table @ZcashWallet
      where_ (wallets ^. ZcashWalletNetwork ==. val (ZcashNetDB n))
@ -269,34 +278,42 @@ getWallets dbFp n =

 -- | Save a new wallet to the database
 saveWallet ::
-     T.Text -- ^ The database path to use
+     ConnectionPool -- ^ The database path to use
  -> ZcashWallet -- ^ The wallet to add to the database
  -> IO (Maybe (Entity ZcashWallet))
-saveWallet dbFp w = PS.runSqlite dbFp $ insertUniqueEntity w
+saveWallet pool w =
+  runNoLoggingT $
+  PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUniqueEntity w

 -- | Update the last sync block for the wallet
-updateWalletSync :: T.Text -> Int -> ZcashWalletId -> IO ()
-updateWalletSync dbPath b i = do
-  PS.runSqlite dbPath $ do
+updateWalletSync :: ConnectionPool -> Int -> ZcashWalletId -> IO ()
+updateWalletSync pool b i = do
+  runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      update $ \w -> do
        set w [ZcashWalletLastSync =. val b]
        where_ $ w ^. ZcashWalletId ==. val i

 -- | Returns a list of accounts associated with the given wallet
 getAccounts ::
-     T.Text -- ^ The database path
+     ConnectionPool -- ^ The database path
  -> ZcashWalletId -- ^ The wallet ID to check
-  -> IO [Entity ZcashAccount]
-getAccounts dbFp w =
-  PS.runSqlite dbFp $
+  -> NoLoggingT IO [Entity ZcashAccount]
+getAccounts pool w =
+  PS.retryOnBusy $
+  flip PS.runSqlPool pool $ do
    select $ do
      accs <- from $ table @ZcashAccount
      where_ (accs ^. ZcashAccountWalletId ==. val w)
      pure accs

-getAccountById :: T.Text -> ZcashAccountId -> IO (Maybe (Entity ZcashAccount))
-getAccountById dbPath za = do
-  PS.runSqlite dbPath $
+getAccountById ::
+     ConnectionPool -> ZcashAccountId -> IO (Maybe (Entity ZcashAccount))
+getAccountById pool za = do
+  runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      selectOne $ do
        accs <- from $ table @ZcashAccount
        where_ (accs ^. ZcashAccountId ==. val za)
@ -304,12 +321,14 @@ getAccountById dbPath za = do

 -- | Returns the largest account index for the given wallet
 getMaxAccount ::
-     T.Text -- ^ The database path
+     ConnectionPool -- ^ The database path
  -> ZcashWalletId -- ^ The wallet ID to check
  -> IO Int
-getMaxAccount dbFp w = do
+getMaxAccount pool w = do
  a <-
-    PS.runSqlite dbFp $
+    runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      selectOne $ do
        accs <- from $ table @ZcashAccount
        where_ (accs ^. ZcashAccountWalletId ==. val w)
@ -321,18 +340,21 @@ getMaxAccount dbFp w = do

 -- | Save a new account to the database
 saveAccount ::
-     T.Text -- ^ The database path
+     ConnectionPool -- ^ The database path
  -> ZcashAccount -- ^ The account to add to the database
  -> IO (Maybe (Entity ZcashAccount))
-saveAccount dbFp a = PS.runSqlite dbFp $ insertUniqueEntity a
+saveAccount pool a =
+  runNoLoggingT $
+  PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUniqueEntity a

 -- | Returns the largest block in storage
 getMaxBlock ::
-     T.Text -- ^ The database path
-  -> IO Int
-getMaxBlock dbPath = do
+     Pool SqlBackend -- ^ The database pool
+  -> NoLoggingT IO Int
+getMaxBlock pool = do
  b <-
-    PS.runSqlite dbPath $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      selectOne $ do
        txs <- from $ table @ZcashTransaction
        where_ (txs ^. ZcashTransactionBlock >. val 0)
@ -344,20 +366,24 @@ getMaxBlock dbPath = do

 -- | Returns a list of addresses associated with the given account
 getAddresses ::
-     T.Text -- ^ The database path
+     ConnectionPool -- ^ The database path
  -> ZcashAccountId -- ^ The account ID to check
-  -> IO [Entity WalletAddress]
-getAddresses dbFp a =
-  PS.runSqlite dbFp $
+  -> NoLoggingT IO [Entity WalletAddress]
+getAddresses pool a =
+  PS.retryOnBusy $
+  flip PS.runSqlPool pool $ do
    select $ do
      addrs <- from $ table @WalletAddress
      where_ (addrs ^. WalletAddressAccId ==. val a)
      where_ (addrs ^. WalletAddressScope ==. val (ScopeDB External))
      pure addrs

-getAddressById :: T.Text -> WalletAddressId -> IO (Maybe (Entity WalletAddress))
-getAddressById dbPath a = do
-  PS.runSqlite dbPath $
+getAddressById ::
+     ConnectionPool -> WalletAddressId -> IO (Maybe (Entity WalletAddress))
+getAddressById pool a = do
+  runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      selectOne $ do
        addr <- from $ table @WalletAddress
        where_ (addr ^. WalletAddressId ==. val a)
@ -365,11 +391,12 @@ getAddressById dbPath a = do

 -- | Returns a list of change addresses associated with the given account
 getInternalAddresses ::
-     T.Text -- ^ The database path
+     ConnectionPool -- ^ The database path
  -> ZcashAccountId -- ^ The account ID to check
-  -> IO [Entity WalletAddress]
-getInternalAddresses dbFp a =
-  PS.runSqlite dbFp $
+  -> NoLoggingT IO [Entity WalletAddress]
+getInternalAddresses pool a =
+  PS.retryOnBusy $
+  flip PS.runSqlPool pool $ do
    select $ do
      addrs <- from $ table @WalletAddress
      where_ (addrs ^. WalletAddressAccId ==. val a)
@ -378,23 +405,25 @@ getInternalAddresses dbFp a =

 -- | Returns a list of addressess associated with the given wallet
 getWalletAddresses ::
-     T.Text -- ^ The database path
+     ConnectionPool -- ^ The database path
  -> ZcashWalletId -- ^ the wallet to search
-  -> IO [Entity WalletAddress]
-getWalletAddresses dbFp w = do
-  accs <- getAccounts dbFp w
-  addrs <- mapM (getAddresses dbFp . entityKey) accs
+  -> NoLoggingT IO [Entity WalletAddress]
+getWalletAddresses pool w = do
+  accs <- getAccounts pool w
+  addrs <- mapM (getAddresses pool . entityKey) accs
  return $ concat addrs

 -- | Returns the largest address index for the given account
 getMaxAddress ::
-     T.Text -- ^ The database path
+     ConnectionPool -- ^ The database path
  -> ZcashAccountId -- ^ The account ID to check
  -> Scope -- ^ The scope of the address
  -> IO Int
-getMaxAddress dbFp aw s = do
+getMaxAddress pool aw s = do
  a <-
-    PS.runSqlite dbFp $
+    runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      selectOne $ do
        addrs <- from $ table @WalletAddress
        where_ $ addrs ^. WalletAddressAccId ==. val aw
@ -407,19 +436,22 @@ getMaxAddress dbFp aw s = do

 -- | Save a new address to the database
 saveAddress ::
-     T.Text -- ^ the database path
+     ConnectionPool -- ^ the database path
  -> WalletAddress -- ^ The wallet to add to the database
  -> IO (Maybe (Entity WalletAddress))
-saveAddress dbFp w = PS.runSqlite dbFp $ insertUniqueEntity w
+saveAddress pool w =
+  runNoLoggingT $
+  PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUniqueEntity w

 -- | Save a transaction to the data model
 saveTransaction ::
-     T.Text -- ^ the database path
+     ConnectionPool -- ^ the database path
  -> Int -- ^ block time
  -> Transaction -- ^ The transaction to save
-  -> IO (Key ZcashTransaction)
-saveTransaction dbFp t wt =
-  PS.runSqlite dbFp $ do
+  -> NoLoggingT IO (Key ZcashTransaction)
+saveTransaction pool t wt =
+  PS.retryOnBusy $
+  flip PS.runSqlPool pool $ do
    let ix = [0 ..]
    w <-
      insert $
@ -500,11 +532,13 @@ saveTransaction dbFp t wt =

 -- | Get the transactions from a particular block forward
 getZcashTransactions ::
-     T.Text -- ^ The database path
+     ConnectionPool -- ^ The database path
  -> Int -- ^ Block
  -> IO [Entity ZcashTransaction]
-getZcashTransactions dbFp b =
-  PS.runSqlite dbFp $
+getZcashTransactions pool b =
+  runNoLoggingT $
+  PS.retryOnBusy $
+  flip PS.runSqlPool pool $ do
    select $ do
      txs <- from $ table @ZcashTransaction
      where_ $ txs ^. ZcashTransactionBlock >. val b
@ -514,11 +548,13 @@ getZcashTransactions dbFp b =
 -- * Wallet
 -- | Get the block of the last transaction known to the wallet
 getMaxWalletBlock ::
-     T.Text -- ^ The database path
+     ConnectionPool -- ^ The database path
  -> IO Int
-getMaxWalletBlock dbPath = do
+getMaxWalletBlock pool = do
  b <-
-    PS.runSqlite dbPath $
+    runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      selectOne $ do
        txs <- from $ table @WalletTransaction
        where_ $ txs ^. WalletTransactionBlock >. val 0
@ -528,10 +564,12 @@ getMaxWalletBlock dbPath = do
    Nothing -> return $ -1
    Just x -> return $ walletTransactionBlock $ entityVal x

-getMinBirthdayHeight :: T.Text -> IO Int
-getMinBirthdayHeight dbPath = do
+getMinBirthdayHeight :: ConnectionPool -> IO Int
+getMinBirthdayHeight pool = do
  b <-
-    PS.runSqlite dbPath $
+    runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      selectOne $ do
        w <- from $ table @ZcashWallet
        where_ (w ^. ZcashWalletBirthdayHeight >. val 0)
@ -543,13 +581,15 @@ getMinBirthdayHeight dbPath = do

 -- | Save a @WalletTransaction@
 saveWalletTransaction ::
-     T.Text
+     ConnectionPool
  -> ZcashAccountId
  -> Entity ZcashTransaction
  -> IO WalletTransactionId
-saveWalletTransaction dbPath za zt = do
+saveWalletTransaction pool za zt = do
  let zT' = entityVal zt
-  PS.runSqlite dbPath $ do
+  runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      t <-
        upsert
          (WalletTransaction
@ -563,7 +603,7 @@ saveWalletTransaction dbPath za zt = do

 -- | Save a @WalletSapNote@
 saveWalletSapNote ::
-     T.Text -- ^ The database path
+     ConnectionPool -- ^ The database path
  -> WalletTransactionId -- ^ The index for the transaction that contains the note
  -> Integer -- ^ note position
  -> SaplingWitness -- ^ the Sapling incremental witness
@ -572,8 +612,10 @@ saveWalletSapNote ::
  -> ShieldOutputId
  -> DecodedNote -- The decoded Sapling note
  -> IO ()
-saveWalletSapNote dbPath wId pos wit ch za zt dn = do
-  PS.runSqlite dbPath $ do
+saveWalletSapNote pool wId pos wit ch za zt dn = do
+  runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      _ <-
        upsert
          (WalletSapNote
@ -594,7 +636,7 @@ saveWalletSapNote dbPath wId pos wit ch za zt dn = do

 -- | Save a @WalletOrchNote@
 saveWalletOrchNote ::
-     T.Text
+     ConnectionPool
  -> WalletTransactionId
  -> Integer
  -> OrchardWitness
@ -603,8 +645,10 @@ saveWalletOrchNote ::
  -> OrchActionId
  -> DecodedNote
  -> IO ()
-saveWalletOrchNote dbPath wId pos wit ch za zt dn = do
-  PS.runSqlite dbPath $ do
+saveWalletOrchNote pool wId pos wit ch za zt dn = do
+  runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      _ <-
        upsert
          (WalletOrchNote
@ -626,11 +670,11 @@ saveWalletOrchNote dbPath wId pos wit ch za zt dn = do

 -- | Find the Transparent Notes that match the given transparent receiver
 findTransparentNotes ::
-     T.Text -- ^ The database path
+     ConnectionPool -- ^ The database path
  -> Int -- ^ Starting block
  -> Entity WalletAddress
  -> IO ()
-findTransparentNotes dbPath b t = do
+findTransparentNotes pool b t = do
  let tReceiver = t_rec =<< readUnifiedAddressDB (entityVal t)
  case tReceiver of
    Just tR -> do
@ -641,7 +685,9 @@ findTransparentNotes dbPath b t = do
              , BS.pack [0x88, 0xAC]
              ]
      tN <-
-        PS.runSqlite dbPath $
+        runNoLoggingT $
+        PS.retryOnBusy $
+        flip PS.runSqlPool pool $ do
          select $ do
            (txs :& tNotes) <-
              from $ table @ZcashTransaction `innerJoin` table @TransparentNote `on`
@ -652,7 +698,7 @@ findTransparentNotes dbPath b t = do
            pure (txs, tNotes)
      mapM_
        (saveWalletTrNote
-           dbPath
+           pool
           (getScope $ walletAddressScope $ entityVal t)
           (walletAddressAccId $ entityVal t)
           (entityKey t))
@ -661,15 +707,17 @@ findTransparentNotes dbPath b t = do

 -- | Add the transparent notes to the wallet
 saveWalletTrNote ::
-     T.Text -- ^ the database path
+     ConnectionPool -- ^ the database path
  -> Scope
  -> ZcashAccountId
  -> WalletAddressId
  -> (Entity ZcashTransaction, Entity TransparentNote)
  -> IO ()
-saveWalletTrNote dbPath ch za wa (zt, tn) = do
+saveWalletTrNote pool ch za wa (zt, tn) = do
  let zT' = entityVal zt
-  PS.runSqlite dbPath $ do
+  runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      t <-
        upsert
          (WalletTransaction
@ -691,16 +739,19 @@ saveWalletTrNote dbPath ch za wa (zt, tn) = do
          (fromIntegral $ transparentNotePosition $ entityVal tn)

 -- | Save a Sapling note to the wallet database
-saveSapNote :: T.Text -> WalletSapNote -> IO ()
-saveSapNote dbPath wsn = PS.runSqlite dbPath $ do insert_ wsn
+saveSapNote :: ConnectionPool -> WalletSapNote -> IO ()
+saveSapNote pool wsn =
+  runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ insert_ wsn

 -- | Get the shielded outputs from the given blockheight
 getShieldedOutputs ::
-     T.Text -- ^ database path
+     ConnectionPool -- ^ database path
  -> Int -- ^ block
  -> IO [(Entity ZcashTransaction, Entity ShieldOutput)]
-getShieldedOutputs dbPath b =
-  PS.runSqlite dbPath $ do
+getShieldedOutputs pool b =
+  runNoLoggingT $
+  PS.retryOnBusy $
+  flip PS.runSqlPool pool $ do
    select $ do
      (txs :& sOutputs) <-
        from $ table @ZcashTransaction `innerJoin` table @ShieldOutput `on`
@ -715,11 +766,13 @@ getShieldedOutputs dbPath b =

 -- | Get the Orchard actions from the given blockheight forward
 getOrchardActions ::
-     T.Text -- ^ database path
+     ConnectionPool -- ^ database path
  -> Int -- ^ block
  -> IO [(Entity ZcashTransaction, Entity OrchAction)]
-getOrchardActions dbPath b =
-  PS.runSqlite dbPath $ do
+getOrchardActions pool b =
+  runNoLoggingT $
+  PS.retryOnBusy $
+  flip PS.runSqlPool pool $ do
    select $ do
      (txs :& oActions) <-
        from $ table @ZcashTransaction `innerJoin` table @OrchAction `on`
@ -732,12 +785,12 @@ getOrchardActions dbPath b =

 -- | Get the transactions belonging to the given address
 getWalletTransactions ::
-     T.Text -- ^ database path
+     ConnectionPool -- ^ database path
  -> Entity WalletAddress
-  -> IO ()
-getWalletTransactions dbPath w = do
+  -> NoLoggingT IO ()
+getWalletTransactions pool w = do
  let w' = entityVal w
-  chgAddr <- getInternalAddresses dbPath $ walletAddressAccId $ entityVal w
+  chgAddr <- getInternalAddresses pool $ walletAddressAccId $ entityVal w
  let ctReceiver = t_rec =<< readUnifiedAddressDB (entityVal $ head chgAddr)
  let csReceiver = s_rec =<< readUnifiedAddressDB (entityVal $ head chgAddr)
  let coReceiver = o_rec =<< readUnifiedAddressDB (entityVal $ head chgAddr)
@ -754,7 +807,8 @@ getWalletTransactions dbPath w = do
                , (toBytes . tr_bytes) tR
                , BS.pack [0x88, 0xAC]
                ]
-        PS.runSqlite dbPath $ do
+        PS.retryOnBusy $
+          flip PS.runSqlPool pool $ do
            select $ do
              tnotes <- from $ table @WalletTrNote
              where_ (tnotes ^. WalletTrNoteScript ==. val s)
@ -769,13 +823,15 @@ getWalletTransactions dbPath w = do
                , (toBytes . tr_bytes) tR
                , BS.pack [0x88, 0xAC]
                ]
-        PS.runSqlite dbPath $ do
+        PS.retryOnBusy $
+          flip PS.runSqlPool pool $ do
            select $ do
              tnotes <- from $ table @WalletTrNote
              where_ (tnotes ^. WalletTrNoteScript ==. val s1)
              pure tnotes
  trSpends <-
-    PS.runSqlite dbPath $ do
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      select $ do
        trSpends <- from $ table @WalletTrSpend
        where_
@ -786,7 +842,8 @@ getWalletTransactions dbPath w = do
    case sReceiver of
      Nothing -> return []
      Just sR -> do
-        PS.runSqlite dbPath $ do
+        PS.retryOnBusy $
+          flip PS.runSqlPool pool $ do
            select $ do
              snotes <- from $ table @WalletSapNote
              where_ (snotes ^. WalletSapNoteRecipient ==. val (getBytes sR))
@ -795,7 +852,8 @@ getWalletTransactions dbPath w = do
    case csReceiver of
      Nothing -> return []
      Just sR -> do
-        PS.runSqlite dbPath $ do
+        PS.retryOnBusy $
+          flip PS.runSqlPool pool $ do
            select $ do
              snotes <- from $ table @WalletSapNote
              where_ (snotes ^. WalletSapNoteRecipient ==. val (getBytes sR))
@ -805,7 +863,8 @@ getWalletTransactions dbPath w = do
    case oReceiver of
      Nothing -> return []
      Just oR -> do
-        PS.runSqlite dbPath $ do
+        PS.retryOnBusy $
+          flip PS.runSqlPool pool $ do
            select $ do
              onotes <- from $ table @WalletOrchNote
              where_ (onotes ^. WalletOrchNoteRecipient ==. val (getBytes oR))
@ -814,12 +873,14 @@ getWalletTransactions dbPath w = do
    case coReceiver of
      Nothing -> return []
      Just oR -> do
-        PS.runSqlite dbPath $ do
+        PS.retryOnBusy $
+          flip PS.runSqlPool pool $ do
            select $ do
              onotes <- from $ table @WalletOrchNote
              where_ (onotes ^. WalletOrchNoteRecipient ==. val (getBytes oR))
              pure onotes
  orchSpends <- mapM (getOrchSpends . entityKey) (orchNotes <> orchChgNotes)
+  clearUserTx (entityKey w)
  mapM_ addTr trNotes
  mapM_ addTr trChgNotes
  mapM_ addSap sapNotes
@ -830,56 +891,68 @@ getWalletTransactions dbPath w = do
  mapM_ subSSpend $ catMaybes sapSpends
  mapM_ subOSpend $ catMaybes orchSpends
  where
-    getSapSpends :: WalletSapNoteId -> IO (Maybe (Entity WalletSapSpend))
+    clearUserTx :: WalletAddressId -> NoLoggingT IO ()
+    clearUserTx waId = do
+      PS.retryOnBusy $
+        flip PS.runSqlPool pool $ do
+          delete $ do
+            u <- from $ table @UserTx
+            where_ (u ^. UserTxAddress ==. val waId)
+            return ()
+    getSapSpends ::
+         WalletSapNoteId -> NoLoggingT IO (Maybe (Entity WalletSapSpend))
    getSapSpends n = do
-      PS.runSqlite dbPath $ do
+      PS.retryOnBusy $
+        flip PS.runSqlPool pool $ do
          selectOne $ do
            sapSpends <- from $ table @WalletSapSpend
            where_ (sapSpends ^. WalletSapSpendNote ==. val n)
            pure sapSpends
-    getOrchSpends :: WalletOrchNoteId -> IO (Maybe (Entity WalletOrchSpend))
+    getOrchSpends ::
+         WalletOrchNoteId -> NoLoggingT IO (Maybe (Entity WalletOrchSpend))
    getOrchSpends n = do
-      PS.runSqlite dbPath $ do
+      PS.retryOnBusy $
+        flip PS.runSqlPool pool $ do
          selectOne $ do
            orchSpends <- from $ table @WalletOrchSpend
            where_ (orchSpends ^. WalletOrchSpendNote ==. val n)
            pure orchSpends
-    addTr :: Entity WalletTrNote -> IO ()
+    addTr :: Entity WalletTrNote -> NoLoggingT IO ()
    addTr n =
      upsertUserTx
        (walletTrNoteTx $ entityVal n)
        (entityKey w)
        (fromIntegral $ walletTrNoteValue $ entityVal n)
        ""
-    addSap :: Entity WalletSapNote -> IO ()
+    addSap :: Entity WalletSapNote -> NoLoggingT IO ()
    addSap n =
      upsertUserTx
        (walletSapNoteTx $ entityVal n)
        (entityKey w)
        (fromIntegral $ walletSapNoteValue $ entityVal n)
        (walletSapNoteMemo $ entityVal n)
-    addOrch :: Entity WalletOrchNote -> IO ()
+    addOrch :: Entity WalletOrchNote -> NoLoggingT IO ()
    addOrch n =
      upsertUserTx
        (walletOrchNoteTx $ entityVal n)
        (entityKey w)
        (fromIntegral $ walletOrchNoteValue $ entityVal n)
        (walletOrchNoteMemo $ entityVal n)
-    subTSpend :: Entity WalletTrSpend -> IO ()
+    subTSpend :: Entity WalletTrSpend -> NoLoggingT IO ()
    subTSpend n =
      upsertUserTx
        (walletTrSpendTx $ entityVal n)
        (entityKey w)
        (-(fromIntegral $ walletTrSpendValue $ entityVal n))
        ""
-    subSSpend :: Entity WalletSapSpend -> IO ()
+    subSSpend :: Entity WalletSapSpend -> NoLoggingT IO ()
    subSSpend n =
      upsertUserTx
        (walletSapSpendTx $ entityVal n)
        (entityKey w)
        (-(fromIntegral $ walletSapSpendValue $ entityVal n))
        ""
-    subOSpend :: Entity WalletOrchSpend -> IO ()
+    subOSpend :: Entity WalletOrchSpend -> NoLoggingT IO ()
    subOSpend n =
      upsertUserTx
        (walletOrchSpendTx $ entityVal n)
@ -887,16 +960,22 @@ getWalletTransactions dbPath w = do
        (-(fromIntegral $ walletOrchSpendValue $ entityVal n))
        ""
    upsertUserTx ::
-         WalletTransactionId -> WalletAddressId -> Int -> T.Text -> IO ()
+         WalletTransactionId
+      -> WalletAddressId
+      -> Int
+      -> T.Text
+      -> NoLoggingT IO ()
    upsertUserTx tId wId amt memo = do
      tr <-
-        PS.runSqlite dbPath $ do
+        PS.retryOnBusy $
+        flip PS.runSqlPool pool $ do
          select $ do
            tx <- from $ table @WalletTransaction
            where_ (tx ^. WalletTransactionId ==. val tId)
            pure tx
      existingUtx <-
-        PS.runSqlite dbPath $ do
+        PS.retryOnBusy $
+        flip PS.runSqlPool pool $ do
          selectOne $ do
            ut <- from $ table @UserTx
            where_
@ -907,7 +986,8 @@ getWalletTransactions dbPath w = do
      case existingUtx of
        Nothing -> do
          _ <-
-            PS.runSqlite dbPath $ do
+            PS.retryOnBusy $
+            flip PS.runSqlPool pool $ do
              upsert
                (UserTx
                   (walletTransactionTxId $ entityVal $ head tr)
@ -919,7 +999,8 @@ getWalletTransactions dbPath w = do
          return ()
        Just uTx -> do
          _ <-
-            PS.runSqlite dbPath $ do
+            PS.retryOnBusy $
+            flip PS.runSqlPool pool $ do
              update $ \t -> do
                set
                  t
@ -930,33 +1011,40 @@ getWalletTransactions dbPath w = do
                where_ (t ^. UserTxId ==. val (entityKey uTx))
          return ()

-getUserTx :: T.Text -> WalletAddressId -> IO [Entity UserTx]
-getUserTx dbPath aId = do
-  PS.runSqlite dbPath $ do
+getUserTx :: ConnectionPool -> WalletAddressId -> IO [Entity UserTx]
+getUserTx pool aId = do
+  runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      select $ do
        uTxs <- from $ table @UserTx
        where_ (uTxs ^. UserTxAddress ==. val aId)
+        orderBy [asc $ uTxs ^. UserTxTime]
        return uTxs

 -- | Get wallet transparent notes by account
-getWalletTrNotes :: T.Text -> ZcashAccountId -> IO [Entity WalletTrNote]
-getWalletTrNotes dbPath za = do
-  PS.runSqlite dbPath $ do
+getWalletTrNotes :: ConnectionPool -> ZcashAccountId -> IO [Entity WalletTrNote]
+getWalletTrNotes pool za = do
+  runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      select $ do
        n <- from $ table @WalletTrNote
        where_ (n ^. WalletTrNoteAccId ==. val za)
        pure n

 -- | find Transparent spends
-findTransparentSpends :: T.Text -> ZcashAccountId -> IO ()
-findTransparentSpends dbPath za = do
-  notes <- getWalletTrNotes dbPath za
+findTransparentSpends :: ConnectionPool -> ZcashAccountId -> IO ()
+findTransparentSpends pool za = do
+  notes <- getWalletTrNotes pool za
  mapM_ findOneTrSpend notes
  where
    findOneTrSpend :: Entity WalletTrNote -> IO ()
    findOneTrSpend n = do
      mReverseTxId <-
-        PS.runSqlite dbPath $ do
+        runNoLoggingT $
+        PS.retryOnBusy $
+        flip PS.runSqlPool pool $ do
          selectOne $ do
            wtx <- from $ table @WalletTransaction
            where_
@ -969,7 +1057,9 @@ findTransparentSpends dbPath za = do
                HexStringDB $
                HexString $ BS.reverse $ toBytes $ getHex reverseTxId
          s <-
-            PS.runSqlite dbPath $ do
+            runNoLoggingT $
+            PS.retryOnBusy $
+            flip PS.runSqlPool pool $ do
              select $ do
                (tx :& trSpends) <-
                  from $
@ -985,7 +1075,9 @@ findTransparentSpends dbPath za = do
          if null s
            then return ()
            else do
-              PS.runSqlite dbPath $ do
+              runNoLoggingT $
+                PS.retryOnBusy $
+                flip PS.runSqlPool pool $ do
                  _ <-
                    update $ \w -> do
                      set w [WalletTrNoteSpent =. val True]
@ -998,20 +1090,26 @@ findTransparentSpends dbPath za = do
                      za
                      (walletTrNoteValue $ entityVal n)

-getWalletSapNotes :: T.Text -> ZcashAccountId -> IO [Entity WalletSapNote]
-getWalletSapNotes dbPath za = do
-  PS.runSqlite dbPath $ do
+getWalletSapNotes ::
+     ConnectionPool -> ZcashAccountId -> IO [Entity WalletSapNote]
+getWalletSapNotes pool za = do
+  runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      select $ do
        n <- from $ table @WalletSapNote
        where_ (n ^. WalletSapNoteAccId ==. val za)
        pure n

 -- | Sapling DAG-aware spend tracking
-findSapSpends :: T.Text -> ZcashAccountId -> [Entity WalletSapNote] -> IO ()
+findSapSpends ::
+     ConnectionPool -> ZcashAccountId -> [Entity WalletSapNote] -> IO ()
 findSapSpends _ _ [] = return ()
-findSapSpends dbPath za (n:notes) = do
+findSapSpends pool za (n:notes) = do
  s <-
-    PS.runSqlite dbPath $ do
+    runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      select $ do
        (tx :& sapSpends) <-
          from $ table @ZcashTransaction `innerJoin` table @ShieldSpend `on`
@ -1022,9 +1120,11 @@ findSapSpends dbPath za (n:notes) = do
           val (walletSapNoteNullifier (entityVal n)))
        pure (tx, sapSpends)
  if null s
-    then findSapSpends dbPath za notes
+    then findSapSpends pool za notes
    else do
-      PS.runSqlite dbPath $ do
+      runNoLoggingT $
+        PS.retryOnBusy $
+        flip PS.runSqlPool pool $ do
          _ <-
            update $ \w -> do
              set w [WalletSapNoteSpent =. val True]
@ -1036,19 +1136,24 @@ findSapSpends dbPath za (n:notes) = do
              (entityKey n)
              za
              (walletSapNoteValue $ entityVal n)
-      findSapSpends dbPath za notes
+      findSapSpends pool za notes

-getWalletOrchNotes :: T.Text -> ZcashAccountId -> IO [Entity WalletOrchNote]
-getWalletOrchNotes dbPath za = do
-  PS.runSqlite dbPath $ do
+getWalletOrchNotes ::
+     ConnectionPool -> ZcashAccountId -> IO [Entity WalletOrchNote]
+getWalletOrchNotes pool za = do
+  runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      select $ do
        n <- from $ table @WalletOrchNote
        where_ (n ^. WalletOrchNoteAccId ==. val za)
        pure n

-getUnspentSapNotes :: T.Text -> IO [Entity WalletSapNote]
-getUnspentSapNotes dbPath = do
-  PS.runSqlite dbPath $ do
+getUnspentSapNotes :: ConnectionPool -> IO [Entity WalletSapNote]
+getUnspentSapNotes pool = do
+  runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      select $ do
        n <- from $ table @WalletSapNote
        where_ (n ^. WalletSapNoteSpent ==. val False)
@ -1093,9 +1198,11 @@ updateSapNoteRecord pool n w o = do
        ]
      where_ (x ^. WalletSapNoteId ==. val n)

-getUnspentOrchNotes :: T.Text -> IO [Entity WalletOrchNote]
-getUnspentOrchNotes dbPath = do
-  PS.runSqlite dbPath $ do
+getUnspentOrchNotes :: ConnectionPool -> IO [Entity WalletOrchNote]
+getUnspentOrchNotes pool = do
+  runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      select $ do
        n <- from $ table @WalletOrchNote
        where_ (n ^. WalletOrchNoteSpent ==. val False)
@ -1140,11 +1247,14 @@ updateOrchNoteRecord pool n w o = do
        ]
      where_ (x ^. WalletOrchNoteId ==. val n)

-findOrchSpends :: T.Text -> ZcashAccountId -> [Entity WalletOrchNote] -> IO ()
+findOrchSpends ::
+     ConnectionPool -> ZcashAccountId -> [Entity WalletOrchNote] -> IO ()
 findOrchSpends _ _ [] = return ()
-findOrchSpends dbPath za (n:notes) = do
+findOrchSpends pool za (n:notes) = do
  s <-
-    PS.runSqlite dbPath $ do
+    runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      select $ do
        (tx :& orchSpends) <-
          from $ table @ZcashTransaction `innerJoin` table @OrchAction `on`
@ -1155,9 +1265,11 @@ findOrchSpends dbPath za (n:notes) = do
           val (walletOrchNoteNullifier (entityVal n)))
        pure (tx, orchSpends)
  if null s
-    then findOrchSpends dbPath za notes
+    then findOrchSpends pool za notes
    else do
-      PS.runSqlite dbPath $ do
+      runNoLoggingT $
+        PS.retryOnBusy $
+        flip PS.runSqlPool pool $ do
          _ <-
            update $ \w -> do
              set w [WalletOrchNoteSpent =. val True]
@ -1169,7 +1281,7 @@ findOrchSpends dbPath za (n:notes) = do
              (entityKey n)
              za
              (walletOrchNoteValue $ entityVal n)
-      findOrchSpends dbPath za notes
+      findOrchSpends pool za notes

 upsertWalTx ::
     MonadIO m
@ -1186,22 +1298,24 @@ upsertWalTx zt za =
       (zcashTransactionTime zt))
    []

-getBalance :: T.Text -> ZcashAccountId -> IO Integer
-getBalance dbPath za = do
-  trNotes <- getWalletUnspentTrNotes dbPath za
+getBalance :: ConnectionPool -> ZcashAccountId -> IO Integer
+getBalance pool za = do
+  trNotes <- getWalletUnspentTrNotes pool za
  let tAmts = map (walletTrNoteValue . entityVal) trNotes
  let tBal = sum tAmts
-  sapNotes <- getWalletUnspentSapNotes dbPath za
+  sapNotes <- getWalletUnspentSapNotes pool za
  let sAmts = map (walletSapNoteValue . entityVal) sapNotes
  let sBal = sum sAmts
-  orchNotes <- getWalletUnspentOrchNotes dbPath za
+  orchNotes <- getWalletUnspentOrchNotes pool za
  let oAmts = map (walletOrchNoteValue . entityVal) orchNotes
  let oBal = sum oAmts
  return . fromIntegral $ tBal + sBal + oBal

-clearWalletTransactions :: T.Text -> IO ()
-clearWalletTransactions dbPath = do
-  PS.runSqlite dbPath $ do
+clearWalletTransactions :: ConnectionPool -> IO ()
+clearWalletTransactions pool = do
+  runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      delete $ do
        _ <- from $ table @WalletOrchSpend
        return ()
@ -1227,9 +1341,12 @@ clearWalletTransactions dbPath = do
        _ <- from $ table @UserTx
        return ()

-getWalletUnspentTrNotes :: T.Text -> ZcashAccountId -> IO [Entity WalletTrNote]
-getWalletUnspentTrNotes dbPath za = do
-  PS.runSqlite dbPath $ do
+getWalletUnspentTrNotes ::
+     ConnectionPool -> ZcashAccountId -> IO [Entity WalletTrNote]
+getWalletUnspentTrNotes pool za = do
+  runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      select $ do
        n <- from $ table @WalletTrNote
        where_ (n ^. WalletTrNoteAccId ==. val za)
@ -1237,9 +1354,11 @@ getWalletUnspentTrNotes dbPath za = do
        pure n

 getWalletUnspentSapNotes ::
-     T.Text -> ZcashAccountId -> IO [Entity WalletSapNote]
-getWalletUnspentSapNotes dbPath za = do
-  PS.runSqlite dbPath $ do
+     ConnectionPool -> ZcashAccountId -> IO [Entity WalletSapNote]
+getWalletUnspentSapNotes pool za = do
+  runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      select $ do
        n1 <- from $ table @WalletSapNote
        where_ (n1 ^. WalletSapNoteAccId ==. val za)
@ -1247,9 +1366,11 @@ getWalletUnspentSapNotes dbPath za = do
        pure n1

 getWalletUnspentOrchNotes ::
-     T.Text -> ZcashAccountId -> IO [Entity WalletOrchNote]
-getWalletUnspentOrchNotes dbPath za = do
-  PS.runSqlite dbPath $ do
+     ConnectionPool -> ZcashAccountId -> IO [Entity WalletOrchNote]
+getWalletUnspentOrchNotes pool za = do
+  runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      select $ do
        n2 <- from $ table @WalletOrchNote
        where_ (n2 ^. WalletOrchNoteAccId ==. val za)
@ -1257,20 +1378,20 @@ getWalletUnspentOrchNotes dbPath za = do
        pure n2

 selectUnspentNotes ::
-     T.Text
+     ConnectionPool
  -> ZcashAccountId
  -> Integer
  -> IO ([Entity WalletTrNote], [Entity WalletSapNote], [Entity WalletOrchNote])
-selectUnspentNotes dbPath za amt = do
-  trNotes <- getWalletUnspentTrNotes dbPath za
+selectUnspentNotes pool za amt = do
+  trNotes <- getWalletUnspentTrNotes pool za
  let (a1, tList) = checkTransparent (fromIntegral amt) trNotes
  if a1 > 0
    then do
-      sapNotes <- getWalletUnspentSapNotes dbPath za
+      sapNotes <- getWalletUnspentSapNotes pool za
      let (a2, sList) = checkSapling a1 sapNotes
      if a2 > 0
        then do
-          orchNotes <- getWalletUnspentOrchNotes dbPath za
+          orchNotes <- getWalletUnspentOrchNotes pool za
          let (a3, oList) = checkOrchard a2 orchNotes
          if a3 > 0
            then throwIO $ userError "Not enough funds"
@ -1304,9 +1425,12 @@ selectUnspentNotes dbPath za amt = do
             , n : snd (checkOrchard (x - walletOrchNoteValue (entityVal n)) ns))
        else (0, [n])

-getWalletTxId :: T.Text -> WalletTransactionId -> IO (Maybe (Value HexStringDB))
-getWalletTxId dbPath wId = do
-  PS.runSqlite dbPath $ do
+getWalletTxId ::
+     ConnectionPool -> WalletTransactionId -> IO (Maybe (Value HexStringDB))
+getWalletTxId pool wId = do
+  runNoLoggingT $
+    PS.retryOnBusy $
+    flip PS.runSqlPool pool $ do
      selectOne $ do
        wtx <- from $ table @WalletTransaction
        where_ (wtx ^. WalletTransactionId ==. val wId)
--- 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
+          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)
--- 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
Author	SHA1	Message	Date
Rene Vergara	dcbb2fac4a	Implement background sync	2024-05-05 09:49:55 -05:00
pitmutt	1ba188ec24	Merge pull request 'Implement transaction creation' (#77 ) from rav001 into dev041 Reviewed-on: #77	2024-05-03 12:15:11 +00:00