{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeApplications #-} 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 import Data.List (group, sort) import Data.Maybe (catMaybes, fromJust, isJust) import Data.Pool (Pool) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Data.Word import Database.Esqueleto.Experimental import qualified Database.Persist as P import qualified Database.Persist.Sqlite as PS import Database.Persist.TH import Haskoin.Transaction.Common ( OutPoint(..) , TxIn(..) , TxOut(..) , txHashToHex ) import qualified Lens.Micro as ML ((&), (.~), (^.)) import ZcashHaskell.Orchard (isValidUnifiedAddress) import ZcashHaskell.Sapling (decodeSaplingOutputEsk) import ZcashHaskell.Types ( DecodedNote(..) , OrchardAction(..) , OrchardBundle(..) , OrchardSpendingKey(..) , OrchardWitness(..) , SaplingBundle(..) , SaplingCommitmentTree(..) , SaplingSpendingKey(..) , SaplingWitness(..) , Scope(..) , ShieldedOutput(..) , ShieldedSpend(..) , ToBytes(..) , Transaction(..) , TransparentAddress(..) , TransparentBundle(..) , TransparentReceiver(..) , UnifiedAddress(..) , ZcashNet , decodeHexText ) import Zenith.Types ( Config(..) , HexStringDB(..) , OrchardSpendingKeyDB(..) , PhraseDB(..) , RseedDB(..) , SaplingSpendingKeyDB(..) , ScopeDB(..) , TransparentSpendingKeyDB , UnifiedAddressDB(..) , ZcashNetDB(..) ) share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| ZcashWallet name T.Text network ZcashNetDB seedPhrase PhraseDB birthdayHeight Int lastSync Int default=0 UniqueWallet name network deriving Show Eq ZcashAccount index Int walletId ZcashWalletId name T.Text orchSpendKey OrchardSpendingKeyDB sapSpendKey SaplingSpendingKeyDB tPrivateKey TransparentSpendingKeyDB UniqueAccount index walletId UniqueAccName walletId name deriving Show Eq WalletAddress index Int accId ZcashAccountId name T.Text uAddress UnifiedAddressDB scope ScopeDB UniqueAddress index scope accId UniqueAddName accId name deriving Show Eq WalletTransaction txId HexStringDB accId ZcashAccountId block Int conf Int time Int UniqueWTx txId accId deriving Show Eq UserTx hex HexStringDB address WalletAddressId OnDeleteCascade OnUpdateCascade time Int amount Int memo T.Text UniqueUTx hex address deriving Show Eq WalletTrNote tx WalletTransactionId OnDeleteCascade OnUpdateCascade accId ZcashAccountId OnDeleteCascade OnUpdateCascade address WalletAddressId OnDeleteCascade OnUpdateCascade value Word64 spent Bool script BS.ByteString change Bool position Word64 UniqueTNote tx script deriving Show Eq WalletTrSpend tx WalletTransactionId OnDeleteCascade OnUpdateCascade note WalletTrNoteId OnDeleteCascade OnUpdateCascade accId ZcashAccountId OnDeleteCascade OnUpdateCascade value Word64 UniqueTrSpend tx accId deriving Show Eq WalletSapNote tx WalletTransactionId OnDeleteCascade OnUpdateCascade accId ZcashAccountId OnDeleteCascade OnUpdateCascade value Word64 recipient BS.ByteString memo T.Text spent Bool nullifier HexStringDB position Word64 witness HexStringDB change Bool witPos ShieldOutputId OnDeleteIgnore OnUpdateIgnore rseed RseedDB UniqueSapNote tx nullifier deriving Show Eq WalletSapSpend tx WalletTransactionId OnDeleteCascade OnUpdateCascade note WalletSapNoteId OnDeleteCascade OnUpdateCascade accId ZcashAccountId OnDeleteCascade OnUpdateCascade value Word64 UniqueSapSepnd tx accId deriving Show Eq WalletOrchNote tx WalletTransactionId OnDeleteCascade OnUpdateCascade accId ZcashAccountId OnDeleteCascade OnUpdateCascade value Word64 recipient BS.ByteString memo T.Text spent Bool nullifier HexStringDB position Word64 witness HexStringDB change Bool witPos OrchActionId OnDeleteIgnore OnUpdateIgnore rho BS.ByteString rseed RseedDB UniqueOrchNote tx nullifier deriving Show Eq WalletOrchSpend tx WalletTransactionId OnDeleteCascade OnUpdateCascade note WalletOrchNoteId OnDeleteCascade OnUpdateCascade accId ZcashAccountId OnDeleteCascade OnUpdateCascade value Word64 UniqueOrchSpend tx accId deriving Show Eq ZcashTransaction block Int txId HexStringDB conf Int time Int UniqueTx block txId deriving Show Eq TransparentNote tx ZcashTransactionId value Word64 script BS.ByteString position Int UniqueTNPos tx position deriving Show Eq TransparentSpend tx ZcashTransactionId outPointHash HexStringDB outPointIndex Word64 script BS.ByteString seq Word64 position Int UniqueTSPos tx position deriving Show Eq OrchAction tx ZcashTransactionId nf HexStringDB rk HexStringDB cmx HexStringDB ephKey HexStringDB encCipher HexStringDB outCipher HexStringDB cv HexStringDB auth HexStringDB position Int UniqueOAPos tx position deriving Show Eq ShieldOutput tx ZcashTransactionId cv HexStringDB cmu HexStringDB ephKey HexStringDB encCipher HexStringDB outCipher HexStringDB proof HexStringDB position Int UniqueSOPos tx position deriving Show Eq ShieldSpend tx ZcashTransactionId cv HexStringDB anchor HexStringDB nullifier HexStringDB rk HexStringDB proof HexStringDB authSig HexStringDB position Int UniqueSSPos tx position deriving Show Eq AddressBook network ZcashNetDB descrip T.Text abaddress T.Text UniqueABA abaddress deriving Show Eq |] -- * Database functions -- | Initializes the database initDb :: T.Text -- ^ The database path to check -> IO () 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 -> IO () upgradeDb dbName = do PS.runSqlite dbName $ do runMigrationUnsafe migrateAll -- | Get existing wallets from database 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 :: ConnectionPool -- ^ The database path to use -> ZcashWallet -- ^ The wallet to add to the database -> IO (Maybe (Entity ZcashWallet)) saveWallet pool w = runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUniqueEntity w -- | Update the last sync block for the wallet 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 :: ConnectionPool -- ^ The database path -> ZcashWalletId -- ^ The wallet ID to check -> 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 :: 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 :: ConnectionPool -- ^ The database path -> ZcashWalletId -- ^ The wallet ID to check -> IO Int getMaxAccount pool w = do a <- 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 :: ConnectionPool -- ^ The database path -> ZcashAccount -- ^ The account to add to the database -> IO (Maybe (Entity ZcashAccount)) saveAccount pool a = runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUniqueEntity a -- | Returns the largest block in storage getMaxBlock :: Pool SqlBackend -- ^ The database pool -> NoLoggingT IO Int getMaxBlock pool = do b <- 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 :: ConnectionPool -- ^ The database path -> ZcashAccountId -- ^ The account ID to check -> 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 :: 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 :: ConnectionPool -- ^ The database path -> ZcashAccountId -- ^ The account ID to check -> 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 :: ConnectionPool -- ^ The database path -> ZcashWalletId -- ^ the wallet to search -> 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 :: ConnectionPool -- ^ The database path -> ZcashAccountId -- ^ The account ID to check -> Scope -- ^ The scope of the address -> IO Int getMaxAddress pool aw s = do a <- 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 :: ConnectionPool -- ^ the database path -> WalletAddress -- ^ The wallet to add to the database -> IO (Maybe (Entity WalletAddress)) saveAddress pool w = runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUniqueEntity w -- | Save a transaction to the data model saveTransaction :: ConnectionPool -- ^ the database path -> Int -- ^ block time -> Transaction -- ^ The transaction to save -> NoLoggingT IO (Key ZcashTransaction) saveTransaction pool t wt = PS.retryOnBusy $ flip PS.runSqlPool pool $ do let ix = [0 ..] w <- insert $ ZcashTransaction (tx_height wt) (HexStringDB $ tx_id wt) (tx_conf wt) t when (isJust $ tx_transpBundle wt) $ do _ <- insertMany_ $ zipWith (curry (storeTxOut w)) ix $ (tb_vout . fromJust . tx_transpBundle) wt _ <- insertMany_ $ zipWith (curry (storeTxIn w)) ix $ (tb_vin . fromJust . tx_transpBundle) wt return () when (isJust $ tx_saplingBundle wt) $ do _ <- insertMany_ $ zipWith (curry (storeSapSpend w)) ix $ (sbSpends . fromJust . tx_saplingBundle) wt _ <- insertMany_ $ zipWith (curry (storeSapOutput w)) ix $ (sbOutputs . fromJust . tx_saplingBundle) wt return () when (isJust $ tx_orchardBundle wt) $ insertMany_ $ zipWith (curry (storeOrchAction w)) ix $ (obActions . fromJust . tx_orchardBundle) wt return w where storeTxOut :: ZcashTransactionId -> (Int, TxOut) -> TransparentNote storeTxOut wid (i, TxOut v s) = TransparentNote wid (fromIntegral v) s i storeTxIn :: ZcashTransactionId -> (Int, TxIn) -> TransparentSpend storeTxIn wid (i, TxIn (OutPoint h k) s sq) = TransparentSpend wid (HexStringDB . fromText $ txHashToHex h) (fromIntegral k) s (fromIntegral sq) i storeSapSpend :: ZcashTransactionId -> (Int, ShieldedSpend) -> ShieldSpend storeSapSpend wid (i, sp) = ShieldSpend wid (HexStringDB $ sp_cv sp) (HexStringDB $ sp_anchor sp) (HexStringDB $ sp_nullifier sp) (HexStringDB $ sp_rk sp) (HexStringDB $ sp_proof sp) (HexStringDB $ sp_auth sp) i storeSapOutput :: ZcashTransactionId -> (Int, ShieldedOutput) -> ShieldOutput storeSapOutput wid (i, so) = ShieldOutput wid (HexStringDB $ s_cv so) (HexStringDB $ s_cmu so) (HexStringDB $ s_ephKey so) (HexStringDB $ s_encCipherText so) (HexStringDB $ s_outCipherText so) (HexStringDB $ s_proof so) i storeOrchAction :: ZcashTransactionId -> (Int, OrchardAction) -> OrchAction storeOrchAction wid (i, oa) = OrchAction wid (HexStringDB $ nf oa) (HexStringDB $ rk oa) (HexStringDB $ cmx oa) (HexStringDB $ eph_key oa) (HexStringDB $ enc_ciphertext oa) (HexStringDB $ out_ciphertext oa) (HexStringDB $ cv oa) (HexStringDB $ auth oa) i -- | Get the transactions from a particular block forward getZcashTransactions :: ConnectionPool -- ^ The database path -> Int -- ^ Block -> IO [Entity ZcashTransaction] 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 :: ConnectionPool -- ^ The database path -> IO Int getMaxWalletBlock pool = do b <- 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 :: ConnectionPool -> IO Int getMinBirthdayHeight pool = do b <- 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 getLastSyncBlock :: ConnectionPool -> ZcashWalletId -> IO Int getLastSyncBlock pool zw = do b <- runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do selectOne $ do w <- from $ table @ZcashWallet where_ (w ^. ZcashWalletId ==. val zw) pure w case b of Nothing -> throwIO $ userError "Failed to retrieve wallet" Just x -> return $ zcashWalletLastSync $ entityVal x -- | Save a @WalletTransaction@ saveWalletTransaction :: ConnectionPool -> ZcashAccountId -> Entity ZcashTransaction -> IO WalletTransactionId saveWalletTransaction pool za zt = do let zT' = entityVal zt 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 :: ConnectionPool -- ^ The database path -> WalletTransactionId -- ^ The index for the transaction that contains the note -> Integer -- ^ note position -> SaplingWitness -- ^ the Sapling incremental witness -> Bool -- ^ change flag -> ZcashAccountId -> ShieldOutputId -> DecodedNote -- The decoded Sapling note -> IO () 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 :: ConnectionPool -> WalletTransactionId -> Integer -> OrchardWitness -> Bool -> ZcashAccountId -> OrchActionId -> DecodedNote -> IO () 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 :: ConnectionPool -- ^ The database path -> Int -- ^ Starting block -> Entity WalletAddress -> IO () findTransparentNotes pool b t = do let tReceiver = t_rec =<< readUnifiedAddressDB (entityVal t) case tReceiver of Just tR -> do let s = BS.concat [ BS.pack [0x76, 0xA9, 0x14] , (toBytes . tr_bytes) tR , BS.pack [0x88, 0xAC] ] tN <- 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 pool (getScope $ walletAddressScope $ entityVal t) (walletAddressAccId $ entityVal t) (entityKey t)) tN Nothing -> return () -- | Add the transparent notes to the wallet saveWalletTrNote :: ConnectionPool -- ^ the database path -> Scope -> ZcashAccountId -> WalletAddressId -> (Entity ZcashTransaction, Entity TransparentNote) -> IO () saveWalletTrNote pool ch za wa (zt, tn) = do let zT' = entityVal zt 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 :: ConnectionPool -> WalletSapNote -> IO () saveSapNote pool wsn = runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ insert_ wsn -- | Get the shielded outputs from the given blockheight getShieldedOutputs :: ConnectionPool -- ^ database path -> Int -- ^ block -> IO [(Entity ZcashTransaction, Entity ShieldOutput)] getShieldedOutputs pool b = runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do select $ do (txs :& sOutputs) <- from $ table @ZcashTransaction `innerJoin` table @ShieldOutput `on` (\(txs :& sOutputs) -> txs ^. ZcashTransactionId ==. sOutputs ^. ShieldOutputTx) where_ (txs ^. ZcashTransactionBlock >=. val b) orderBy [ asc $ txs ^. ZcashTransactionId , asc $ sOutputs ^. ShieldOutputPosition ] pure (txs, sOutputs) -- | Get the Orchard actions from the given blockheight forward getOrchardActions :: ConnectionPool -- ^ database path -> Int -- ^ block -> IO [(Entity ZcashTransaction, Entity OrchAction)] getOrchardActions pool b = runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do select $ do (txs :& oActions) <- from $ table @ZcashTransaction `innerJoin` table @OrchAction `on` (\(txs :& oActions) -> txs ^. ZcashTransactionId ==. oActions ^. OrchActionTx) where_ (txs ^. ZcashTransactionBlock >=. val b) orderBy [asc $ txs ^. ZcashTransactionId, asc $ oActions ^. OrchActionPosition] pure (txs, oActions) -- | Get the transactions belonging to the given address getWalletTransactions :: ConnectionPool -- ^ database path -> Entity WalletAddress -> NoLoggingT IO () getWalletTransactions pool w = do let w' = 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) let tReceiver = t_rec =<< readUnifiedAddressDB w' let sReceiver = s_rec =<< readUnifiedAddressDB w' let oReceiver = o_rec =<< readUnifiedAddressDB w' trNotes <- case tReceiver of Nothing -> return [] Just tR -> do let s = BS.concat [ BS.pack [0x76, 0xA9, 0x14] , (toBytes . tr_bytes) tR , BS.pack [0x88, 0xAC] ] 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 [] Just tR -> do let s1 = BS.concat [ BS.pack [0x76, 0xA9, 0x14] , (toBytes . tr_bytes) tR , BS.pack [0x88, 0xAC] ] PS.retryOnBusy $ flip PS.runSqlPool pool $ do select $ do tnotes <- from $ table @WalletTrNote where_ (tnotes ^. WalletTrNoteScript ==. val s1) pure tnotes trSpends <- PS.retryOnBusy $ flip PS.runSqlPool pool $ do select $ do trSpends <- from $ table @WalletTrSpend where_ (trSpends ^. WalletTrSpendNote `in_` valList (map entityKey (trNotes <> trChgNotes))) pure trSpends sapNotes <- case sReceiver of Nothing -> return [] Just sR -> do 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.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.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.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 mapM_ addSap sapChgNotes mapM_ addOrch orchNotes mapM_ addOrch orchChgNotes mapM_ subTSpend trSpends mapM_ subSSpend $ catMaybes sapSpends mapM_ subOSpend $ catMaybes orchSpends where 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.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.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 -> NoLoggingT IO () addSap n = upsertUserTx (walletSapNoteTx $ entityVal n) (entityKey w) (fromIntegral $ walletSapNoteValue $ entityVal n) (walletSapNoteMemo $ entityVal n) addOrch :: Entity WalletOrchNote -> NoLoggingT IO () addOrch n = upsertUserTx (walletOrchNoteTx $ entityVal n) (entityKey w) (fromIntegral $ walletOrchNoteValue $ entityVal n) (walletOrchNoteMemo $ entityVal n) subTSpend :: Entity WalletTrSpend -> NoLoggingT IO () subTSpend n = upsertUserTx (walletTrSpendTx $ entityVal n) (entityKey w) (-(fromIntegral $ walletTrSpendValue $ entityVal n)) "" subSSpend :: Entity WalletSapSpend -> NoLoggingT IO () subSSpend n = upsertUserTx (walletSapSpendTx $ entityVal n) (entityKey w) (-(fromIntegral $ walletSapSpendValue $ entityVal n)) "" subOSpend :: Entity WalletOrchSpend -> NoLoggingT IO () subOSpend n = upsertUserTx (walletOrchSpendTx $ entityVal n) (entityKey w) (-(fromIntegral $ walletOrchSpendValue $ entityVal n)) "" upsertUserTx :: WalletTransactionId -> WalletAddressId -> Int -> T.Text -> NoLoggingT IO () upsertUserTx tId wId amt memo = do tr <- PS.retryOnBusy $ flip PS.runSqlPool pool $ do select $ do tx <- from $ table @WalletTransaction where_ (tx ^. WalletTransactionId ==. val tId) pure tx existingUtx <- PS.retryOnBusy $ flip PS.runSqlPool pool $ do selectOne $ do ut <- from $ table @UserTx where_ (ut ^. UserTxHex ==. val (walletTransactionTxId $ entityVal $ head tr)) where_ (ut ^. UserTxAddress ==. val wId) pure ut case existingUtx of Nothing -> do _ <- PS.retryOnBusy $ flip PS.runSqlPool pool $ do upsert (UserTx (walletTransactionTxId $ entityVal $ head tr) wId (walletTransactionTime $ entityVal $ head tr) amt memo) [] return () Just uTx -> do _ <- PS.retryOnBusy $ flip PS.runSqlPool pool $ do update $ \t -> do set t [ UserTxAmount +=. val amt , UserTxMemo =. val (memo <> " " <> userTxMemo (entityVal uTx)) ] where_ (t ^. UserTxId ==. val (entityKey uTx)) return () 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 :: 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 :: ConnectionPool -> ZcashAccountId -> IO () findTransparentSpends pool za = do notes <- getWalletTrNotes pool za mapM_ findOneTrSpend notes where findOneTrSpend :: Entity WalletTrNote -> IO () findOneTrSpend n = do mReverseTxId <- runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do selectOne $ do wtx <- from $ table @WalletTransaction where_ (wtx ^. WalletTransactionId ==. val (walletTrNoteTx $ entityVal n)) pure $ wtx ^. WalletTransactionTxId case mReverseTxId of Nothing -> throwIO $ userError "failed to get tx ID" Just (Value reverseTxId) -> do let flipTxId = HexStringDB $ HexString $ BS.reverse $ toBytes $ getHex reverseTxId s <- runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do select $ do (tx :& trSpends) <- from $ table @ZcashTransaction `innerJoin` table @TransparentSpend `on` (\(tx :& trSpends) -> tx ^. ZcashTransactionId ==. trSpends ^. TransparentSpendTx) where_ (trSpends ^. TransparentSpendOutPointHash ==. val flipTxId) where_ (trSpends ^. TransparentSpendOutPointIndex ==. val (walletTrNotePosition $ entityVal n)) pure (tx, trSpends) if null s then return () else do 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 _ <- upsert (WalletTrSpend (entityKey t') (entityKey n) za (walletTrNoteValue $ entityVal n)) [] return () 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 :: ConnectionPool -> ZcashAccountId -> [Entity WalletSapNote] -> IO () findSapSpends _ _ [] = return () findSapSpends pool za (n:notes) = do s <- runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do select $ do (tx :& sapSpends) <- from $ table @ZcashTransaction `innerJoin` table @ShieldSpend `on` (\(tx :& sapSpends) -> tx ^. ZcashTransactionId ==. sapSpends ^. ShieldSpendTx) where_ (sapSpends ^. ShieldSpendNullifier ==. val (walletSapNoteNullifier (entityVal n))) pure (tx, sapSpends) if null s then findSapSpends pool za notes else do 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 _ <- upsert (WalletSapSpend (entityKey t') (entityKey n) za (walletSapNoteValue $ entityVal n)) [] return () findSapSpends pool za notes 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 :: 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 PS.runSqlPool (select $ do n <- from $ table @ShieldOutput where_ (n ^. ShieldOutputId >. val zt) orderBy [asc $ n ^. ShieldOutputId] pure $ n ^. ShieldOutputCmu) pool getMaxSaplingNote :: Pool SqlBackend -> IO ShieldOutputId getMaxSaplingNote pool = do flip PS.runSqlPool pool $ do x <- selectOne $ do n <- from $ table @ShieldOutput where_ (n ^. ShieldOutputId >. val (toSqlKey 0)) orderBy [desc $ n ^. ShieldOutputId] pure (n ^. ShieldOutputId) case x of Nothing -> return $ toSqlKey 0 Just (Value y) -> return y updateSapNoteRecord :: Pool SqlBackend -> WalletSapNoteId -> SaplingWitness -> ShieldOutputId -> IO () updateSapNoteRecord pool n w o = do flip PS.runSqlPool pool $ do update $ \x -> do set x [ WalletSapNoteWitness =. val (HexStringDB $ sapWit w) , WalletSapNoteWitPos =. val o ] where_ (x ^. WalletSapNoteId ==. val 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 PS.runSqlPool (select $ do n <- from $ table @OrchAction where_ (n ^. OrchActionId >. val zt) orderBy [asc $ n ^. OrchActionId] pure $ n ^. OrchActionCmx) pool getMaxOrchardNote :: Pool SqlBackend -> IO OrchActionId getMaxOrchardNote pool = do flip PS.runSqlPool pool $ do x <- selectOne $ do n <- from $ table @OrchAction where_ (n ^. OrchActionId >. val (toSqlKey 0)) orderBy [desc $ n ^. OrchActionId] pure (n ^. OrchActionId) case x of Nothing -> return $ toSqlKey 0 Just (Value y) -> return y updateOrchNoteRecord :: Pool SqlBackend -> WalletOrchNoteId -> OrchardWitness -> OrchActionId -> IO () updateOrchNoteRecord pool n w o = do flip PS.runSqlPool pool $ do update $ \x -> do set x [ WalletOrchNoteWitness =. val (HexStringDB $ orchWit w) , WalletOrchNoteWitPos =. val o ] where_ (x ^. WalletOrchNoteId ==. val n) findOrchSpends :: ConnectionPool -> ZcashAccountId -> [Entity WalletOrchNote] -> IO () findOrchSpends _ _ [] = return () findOrchSpends pool za (n:notes) = do s <- runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do select $ do (tx :& orchSpends) <- from $ table @ZcashTransaction `innerJoin` table @OrchAction `on` (\(tx :& orchSpends) -> tx ^. ZcashTransactionId ==. orchSpends ^. OrchActionTx) where_ (orchSpends ^. OrchActionNf ==. val (walletOrchNoteNullifier (entityVal n))) pure (tx, orchSpends) if null s then findOrchSpends pool za notes else do 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 _ <- upsert (WalletOrchSpend (entityKey t') (entityKey n) za (walletOrchNoteValue $ entityVal n)) [] return () findOrchSpends pool za notes upsertWalTx :: MonadIO m => ZcashTransaction -> ZcashAccountId -> SqlPersistT m (Entity WalletTransaction) upsertWalTx zt za = upsert (WalletTransaction (zcashTransactionTxId zt) za (zcashTransactionBlock zt) (zcashTransactionConf zt) (zcashTransactionTime zt)) [] 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 pool za let sAmts = map (walletSapNoteValue . entityVal) sapNotes let sBal = sum sAmts orchNotes <- getWalletUnspentOrchNotes pool za let oAmts = map (walletOrchNoteValue . entityVal) orchNotes let oBal = sum oAmts return . fromIntegral $ tBal + sBal + oBal clearWalletTransactions :: ConnectionPool -> IO () clearWalletTransactions pool = do runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do delete $ do _ <- from $ table @UserTx return () 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 () 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 :: 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 :: 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 :: ConnectionPool -> ZcashAccountId -> Integer -> IO ([Entity WalletTrNote], [Entity WalletSapNote], [Entity WalletOrchNote]) selectUnspentNotes pool za amt = do trNotes <- getWalletUnspentTrNotes pool za let (a1, tList) = checkTransparent (fromIntegral amt) trNotes if a1 > 0 then do sapNotes <- getWalletUnspentSapNotes pool za let (a2, sList) = checkSapling a1 sapNotes if a2 > 0 then do orchNotes <- getWalletUnspentOrchNotes pool za let (a3, oList) = checkOrchard a2 orchNotes if a3 > 0 then throwIO $ userError "Not enough funds" else return (tList, sList, oList) else return (tList, sList, []) else return (tList, [], []) where checkTransparent :: Word64 -> [Entity WalletTrNote] -> (Word64, [Entity WalletTrNote]) checkTransparent x [] = (x, []) checkTransparent x (n:ns) = if walletTrNoteValue (entityVal n) < x then ( fst (checkTransparent (x - walletTrNoteValue (entityVal n)) ns) , n : snd (checkTransparent (x - walletTrNoteValue (entityVal n)) ns)) else (0, [n]) checkSapling :: Word64 -> [Entity WalletSapNote] -> (Word64, [Entity WalletSapNote]) checkSapling x [] = (x, []) checkSapling x (n:ns) = if walletSapNoteValue (entityVal n) < x then ( fst (checkSapling (x - walletSapNoteValue (entityVal n)) ns) , n : snd (checkSapling (x - walletSapNoteValue (entityVal n)) ns)) else (0, [n]) checkOrchard :: Word64 -> [Entity WalletOrchNote] -> (Word64, [Entity WalletOrchNote]) checkOrchard x [] = (x, []) checkOrchard x (n:ns) = if walletOrchNoteValue (entityVal n) < x then ( fst (checkOrchard (x - walletOrchNoteValue (entityVal n)) ns) , n : snd (checkOrchard (x - walletOrchNoteValue (entityVal n)) ns)) else (0, [n]) 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 readUnifiedAddressDB = isValidUnifiedAddress . TE.encodeUtf8 . getUA . walletAddressUAddress -- | Get list of external zcash addresses from database getAdrBook :: ConnectionPool -> ZcashNet -> IO [Entity AddressBook] getAdrBook pool n = runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do select $ do adrbook <- from $ table @AddressBook where_ (adrbook ^. AddressBookNetwork ==. val (ZcashNetDB n)) pure adrbook -- | Save a new address into AddressBook saveAdrsInAdrBook :: ConnectionPool -- ^ The database path to use -> AddressBook -- ^ The address to add to the database -> IO (Maybe (Entity AddressBook)) saveAdrsInAdrBook pool a = runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ insertUniqueEntity a -- | Update an existing address into AddressBook updateAdrsInAdrBook :: ConnectionPool -> T.Text -> T.Text -> T.Text -> IO () updateAdrsInAdrBook pool d a ia = do runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do update $ \ab -> do set ab [AddressBookDescrip =. val d, AddressBookAbaddress =. val a] where_ $ ab ^. AddressBookAbaddress ==. val ia -- | Get one AddrssBook record using the Address as a key -- getABookRec :: ConnectionPool -> T.Tex t -> IO (Maybe (Entity AddressBook)) -- getABookRec pool a = do -- runNoLoggingT $ -- PS.retryOnBusy $ -- flip PS.runSqlPool pool $ -- select $ do -- adrbook <- from $ table @AddressBook -- where_ ((adrbook ^. AddressBookAbaddress) ==. val a) -- return adrbook -- | delete an existing address from AddressBook deleteAdrsFromAB :: ConnectionPool -> T.Text -> IO () deleteAdrsFromAB pool ia = do runNoLoggingT $ PS.retryOnBusy $ flip PS.runSqlPool pool $ do delete $ do ab <- from $ table @AddressBook where_ (ab ^. AddressBookAbaddress ==. val ia) rmdups :: Ord a => [a] -> [a] rmdups = map head . group . sort