zenith/src/Zenith/DB.hs

526 lines
15 KiB
Haskell
Raw Normal View History

2024-01-22 18:58:37 +00:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DerivingStrategies #-}
2024-03-01 20:57:13 +00:00
{-# LANGUAGE DeriveAnyClass #-}
2024-01-22 18:58:37 +00:00
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
2024-01-23 15:55:24 +00:00
{-# LANGUAGE TypeOperators #-}
2024-04-07 14:25:25 +00:00
{-# LANGUAGE TypeApplications #-}
2024-01-22 18:58:37 +00:00
2024-01-17 18:15:21 +00:00
module Zenith.DB where
2024-01-22 18:58:37 +00:00
2024-04-03 20:14:14 +00:00
import Control.Monad (when)
2024-04-08 20:51:14 +00:00
import Data.Bifunctor
2024-01-22 18:58:37 +00:00
import qualified Data.ByteString as BS
import Data.HexString
2024-04-03 20:14:14 +00:00
import Data.Maybe (fromJust, isJust)
2024-01-22 18:58:37 +00:00
import qualified Data.Text as T
2024-04-07 14:25:25 +00:00
import qualified Data.Text.Encoding as TE
import Database.Esqueleto.Experimental
import qualified Database.Persist as P
import qualified Database.Persist.Sqlite as PS
2024-01-22 18:58:37 +00:00
import Database.Persist.TH
2024-04-07 14:25:25 +00:00
import Haskoin.Transaction.Common
( OutPoint(..)
, TxIn(..)
, TxOut(..)
, txHashToHex
)
import ZcashHaskell.Orchard (isValidUnifiedAddress)
2024-04-08 20:51:14 +00:00
import ZcashHaskell.Sapling (decodeSaplingOutputEsk)
2024-04-03 20:14:14 +00:00
import ZcashHaskell.Types
2024-04-08 20:51:14 +00:00
( DecodedNote(..)
, OrchardAction(..)
2024-04-03 20:14:14 +00:00
, OrchardBundle(..)
, SaplingBundle(..)
, Scope(..)
, ShieldedOutput(..)
, ShieldedSpend(..)
, Transaction(..)
2024-04-07 14:25:25 +00:00
, TransparentAddress(..)
2024-04-03 20:14:14 +00:00
, TransparentBundle(..)
2024-04-07 14:25:25 +00:00
, UnifiedAddress(..)
2024-04-03 20:14:14 +00:00
, ZcashNet
)
2024-03-17 12:17:52 +00:00
import Zenith.Types
( HexStringDB(..)
, OrchardSpendingKeyDB(..)
2024-03-17 12:17:52 +00:00
, PhraseDB(..)
, SaplingSpendingKeyDB(..)
, ScopeDB(..)
, TransparentSpendingKeyDB
, UnifiedAddressDB(..)
, ZcashNetDB(..)
)
2024-03-05 18:34:30 +00:00
2024-01-22 18:58:37 +00:00
share
[mkPersist sqlSettings, mkMigrate "migrateAll"]
[persistLowerCase|
ZcashWallet
name T.Text
2024-03-17 12:17:52 +00:00
network ZcashNetDB
seedPhrase PhraseDB
2024-03-01 20:57:13 +00:00
birthdayHeight Int
UniqueWallet name network
2024-03-01 20:57:13 +00:00
deriving Show Eq
ZcashAccount
index Int
2024-03-01 20:57:13 +00:00
walletId ZcashWalletId
name T.Text
2024-03-17 12:17:52 +00:00
orchSpendKey OrchardSpendingKeyDB
sapSpendKey SaplingSpendingKeyDB
tPrivateKey TransparentSpendingKeyDB
2024-03-01 20:57:13 +00:00
UniqueAccount index walletId
2024-03-05 18:34:30 +00:00
UniqueAccName walletId name
2024-03-01 20:57:13 +00:00
deriving Show Eq
WalletAddress
index Int
2024-03-05 18:34:30 +00:00
accId ZcashAccountId
name T.Text
2024-03-17 12:17:52 +00:00
uAddress UnifiedAddressDB
scope ScopeDB
UniqueAddress index scope accId
2024-03-05 18:34:30 +00:00
UniqueAddName accId name
2024-03-01 20:57:13 +00:00
deriving Show Eq
WalletTransaction
2024-04-04 18:21:55 +00:00
txId HexStringDB
2024-04-04 19:35:08 +00:00
block Int
2024-04-04 18:21:55 +00:00
conf Int
time Int
2024-04-07 14:25:25 +00:00
UniqueWTx txId
2024-04-04 18:21:55 +00:00
deriving Show Eq
WalletTrNote
tx WalletTransactionId
2024-04-04 19:35:08 +00:00
addrId WalletAddressId
2024-04-04 18:21:55 +00:00
value Int
rawId TransparentNoteId
spent Bool
deriving Show Eq
WalletSapNote
tx WalletTransactionId
2024-04-04 19:35:08 +00:00
addrId WalletAddressId
2024-04-04 18:21:55 +00:00
value Int
recipient BS.ByteString
memo T.Text
rawId ShieldOutputId
spent Bool
2024-04-07 14:25:25 +00:00
nullifier HexStringDB
2024-04-04 18:21:55 +00:00
deriving Show Eq
WalletOrchNote
tx WalletTransactionId
2024-04-04 19:35:08 +00:00
addrId WalletAddressId
2024-04-04 18:21:55 +00:00
value Int
recipient BS.ByteString
memo T.Text
rawId OrchActionId
spent Bool
2024-04-07 14:25:25 +00:00
nullifier HexStringDB
2024-04-04 18:21:55 +00:00
deriving Show Eq
ZcashTransaction
block Int
txId HexStringDB
conf Int
time Int
deriving Show Eq
2024-04-03 20:14:14 +00:00
TransparentNote
2024-04-04 18:21:55 +00:00
tx ZcashTransactionId
2024-04-03 20:14:14 +00:00
value Int
script BS.ByteString
2024-04-07 14:25:25 +00:00
position Int
UniqueTNPos tx position
deriving Show Eq
TransparentSpend
tx ZcashTransactionId
outPointHash HexStringDB
outPointIndex Int
script BS.ByteString
seq Int
position Int
UniqueTSPos tx position
deriving Show Eq
OrchAction
2024-04-04 18:21:55 +00:00
tx ZcashTransactionId
nf HexStringDB
rk HexStringDB
cmx HexStringDB
ephKey HexStringDB
encCipher HexStringDB
outCipher HexStringDB
cv HexStringDB
auth HexStringDB
2024-04-07 14:25:25 +00:00
position Int
UniqueOAPos tx position
deriving Show Eq
ShieldOutput
2024-04-04 18:21:55 +00:00
tx ZcashTransactionId
cv HexStringDB
cmu HexStringDB
ephKey HexStringDB
encCipher HexStringDB
outCipher HexStringDB
proof HexStringDB
2024-04-07 14:25:25 +00:00
position Int
UniqueSOPos tx position
deriving Show Eq
ShieldSpend
2024-04-04 18:21:55 +00:00
tx ZcashTransactionId
cv HexStringDB
anchor HexStringDB
nullifier HexStringDB
rk HexStringDB
proof HexStringDB
authSig HexStringDB
2024-04-07 14:25:25 +00:00
position Int
UniqueSSPos tx position
deriving Show Eq
|]
2024-03-05 18:34:30 +00:00
-- * Database functions
-- | Initializes the database
initDb ::
T.Text -- ^ The database path to check
-> IO ()
initDb dbName = do
2024-04-07 14:25:25 +00:00
PS.runSqlite dbName $ do runMigration migrateAll
2024-03-05 18:34:30 +00:00
-- | Get existing wallets from database
getWallets :: T.Text -> ZcashNet -> IO [Entity ZcashWallet]
2024-03-17 12:17:52 +00:00
getWallets dbFp n =
2024-04-07 14:25:25 +00:00
PS.runSqlite dbFp $
select $ do
wallets <- from $ table @ZcashWallet
where_ (wallets ^. ZcashWalletNetwork ==. val (ZcashNetDB n))
pure wallets
2024-03-05 18:34:30 +00:00
-- | Save a new wallet to the database
saveWallet ::
T.Text -- ^ The database path to use
-> ZcashWallet -- ^ The wallet to add to the database
-> IO (Maybe (Entity ZcashWallet))
2024-04-07 14:25:25 +00:00
saveWallet dbFp w = PS.runSqlite dbFp $ insertUniqueEntity w
2024-03-05 18:34:30 +00:00
-- | Returns a list of accounts associated with the given wallet
getAccounts ::
T.Text -- ^ The database path
-> ZcashWalletId -- ^ The wallet ID to check
-> IO [Entity ZcashAccount]
2024-04-07 14:25:25 +00:00
getAccounts dbFp w =
PS.runSqlite dbFp $
select $ do
accs <- from $ table @ZcashAccount
where_ (accs ^. ZcashAccountWalletId ==. val w)
pure accs
2024-03-05 18:34:30 +00:00
-- | Returns the largest account index for the given wallet
getMaxAccount ::
T.Text -- ^ The database path
-> ZcashWalletId -- ^ The wallet ID to check
-> IO Int
getMaxAccount dbFp w = do
a <-
2024-04-07 14:25:25 +00:00
PS.runSqlite dbFp $
selectOne $ do
accs <- from $ table @ZcashAccount
where_ (accs ^. ZcashAccountWalletId ==. val w)
orderBy [desc $ accs ^. ZcashAccountIndex]
pure accs
2024-03-05 18:34:30 +00:00
case a of
Nothing -> return $ -1
Just x -> return $ zcashAccountIndex $ entityVal x
-- | Save a new account to the database
saveAccount ::
T.Text -- ^ The database path
-> ZcashAccount -- ^ The account to add to the database
-> IO (Maybe (Entity ZcashAccount))
2024-04-07 14:25:25 +00:00
saveAccount dbFp a = PS.runSqlite dbFp $ insertUniqueEntity a
2024-03-05 18:34:30 +00:00
2024-04-04 18:21:55 +00:00
-- | Returns the largest block in storage
getMaxBlock ::
T.Text -- ^ The database path
-> IO Int
getMaxBlock dbPath = do
b <-
2024-04-07 14:25:25 +00:00
PS.runSqlite dbPath $
selectOne $ do
txs <- from $ table @ZcashTransaction
where_ (txs ^. ZcashTransactionBlock >. val 0)
orderBy [desc $ txs ^. ZcashTransactionBlock]
pure txs
2024-04-04 18:21:55 +00:00
case b of
Nothing -> return $ -1
Just x -> return $ zcashTransactionBlock $ entityVal x
2024-03-05 18:34:30 +00:00
-- | Returns a list of addresses associated with the given account
getAddresses ::
T.Text -- ^ The database path
-> ZcashAccountId -- ^ The account ID to check
-> IO [Entity WalletAddress]
2024-03-17 12:17:52 +00:00
getAddresses dbFp a =
2024-04-07 14:25:25 +00:00
PS.runSqlite dbFp $
select $ do
addrs <- from $ table @WalletAddress
where_ (addrs ^. WalletAddressAccId ==. val a)
where_ (addrs ^. WalletAddressScope ==. val (ScopeDB External))
pure addrs
-- | Returns a list of addressess associated with the given wallet
getWalletAddresses ::
T.Text -- ^ 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
return $ concat addrs
2024-03-05 18:34:30 +00:00
-- | Returns the largest address index for the given account
getMaxAddress ::
T.Text -- ^ The database path
2024-03-17 12:17:52 +00:00
-> ZcashAccountId -- ^ The account ID to check
-> Scope -- ^ The scope of the address
2024-03-05 18:34:30 +00:00
-> IO Int
2024-03-17 12:17:52 +00:00
getMaxAddress dbFp aw s = do
2024-03-05 18:34:30 +00:00
a <-
2024-04-07 14:25:25 +00:00
PS.runSqlite dbFp $
selectOne $ do
addrs <- from $ table @WalletAddress
where_ $ addrs ^. WalletAddressAccId ==. val aw
where_ $ addrs ^. WalletAddressScope ==. val (ScopeDB s)
orderBy [desc $ addrs ^. WalletAddressIndex]
pure addrs
2024-03-05 18:34:30 +00:00
case a of
Nothing -> return $ -1
Just x -> return $ walletAddressIndex $ entityVal x
-- | Save a new address to the database
saveAddress ::
T.Text -- ^ the database path
-> WalletAddress -- ^ The wallet to add to the database
-> IO (Maybe (Entity WalletAddress))
2024-04-07 14:25:25 +00:00
saveAddress dbFp w = PS.runSqlite dbFp $ insertUniqueEntity w
2024-04-03 20:14:14 +00:00
-- | Save a transaction to the data model
saveTransaction ::
T.Text -- ^ the database path
-> Int -- ^ block time
-> Transaction -- ^ The transaction to save
2024-04-04 18:21:55 +00:00
-> IO (Key ZcashTransaction)
2024-04-03 20:14:14 +00:00
saveTransaction dbFp t wt =
2024-04-07 14:25:25 +00:00
PS.runSqlite dbFp $ do
let ix = [0 ..]
2024-04-03 20:14:14 +00:00
w <-
insert $
2024-04-04 18:21:55 +00:00
ZcashTransaction (tx_height wt) (HexStringDB $ tx_id wt) (tx_conf wt) t
2024-04-07 14:25:25 +00:00
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 ()
2024-04-03 20:14:14 +00:00
when (isJust $ tx_saplingBundle wt) $ do
_ <-
insertMany_ $
2024-04-07 14:25:25 +00:00
zipWith (curry (storeSapSpend w)) ix $
(sbSpends . fromJust . tx_saplingBundle) wt
2024-04-03 20:14:14 +00:00
_ <-
insertMany_ $
2024-04-07 14:25:25 +00:00
zipWith (curry (storeSapOutput w)) ix $
(sbOutputs . fromJust . tx_saplingBundle) wt
2024-04-03 20:14:14 +00:00
return ()
when (isJust $ tx_orchardBundle wt) $
insertMany_ $
2024-04-07 14:25:25 +00:00
zipWith (curry (storeOrchAction w)) ix $
(obActions . fromJust . tx_orchardBundle) wt
2024-04-03 20:14:14 +00:00
return w
where
2024-04-07 14:25:25 +00:00
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) =
2024-04-03 20:14:14 +00:00
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)
2024-04-07 14:25:25 +00:00
i
storeSapOutput ::
ZcashTransactionId -> (Int, ShieldedOutput) -> ShieldOutput
storeSapOutput wid (i, so) =
2024-04-03 20:14:14 +00:00
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)
2024-04-07 14:25:25 +00:00
i
storeOrchAction :: ZcashTransactionId -> (Int, OrchardAction) -> OrchAction
storeOrchAction wid (i, oa) =
2024-04-03 20:14:14 +00:00
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)
2024-04-07 14:25:25 +00:00
i
-- | Get the transactions from a particular block forward
getZcashTransactions ::
T.Text -- ^ The database path
-> Int -- ^ Block
-> IO [Entity ZcashTransaction]
getZcashTransactions dbFp b =
PS.runSqlite dbFp $
select $ do
txs <- from $ table @ZcashTransaction
where_ $ txs ^. ZcashTransactionBlock >. val b
orderBy [asc $ txs ^. ZcashTransactionBlock]
return txs
-- * Wallet
-- | Get the block of the last transaction known to the wallet
getMaxWalletBlock ::
T.Text -- ^ The database path
-> IO Int
getMaxWalletBlock dbPath = do
b <-
PS.runSqlite dbPath $
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
-- | Find the Transparent Notes that match the given transparent receiver
findTransparentNotes ::
T.Text -- ^ The database path
-> Int -- ^ Starting block
-> WalletAddress
-> IO [(Entity ZcashTransaction, Entity TransparentNote)]
findTransparentNotes dbPath b t = do
let tReceiver = t_rec =<< readUnifiedAddressDB t
case tReceiver of
Just tR -> do
let s =
BS.concat
[ BS.pack [0x76, 0xA9, 0x14]
, (toBytes . ta_bytes) tR
, BS.pack [0x88, 0xAC]
]
PS.runSqlite dbPath $
select $ do
(txs :& tNotes) <-
from $ table @ZcashTransaction `innerJoin` table @TransparentNote `on`
(\(txs :& tNotes) ->
txs ^. ZcashTransactionId ==. tNotes ^. TransparentNoteTx)
where_ (txs ^. ZcashTransactionBlock >. val b)
where_ (tNotes ^. TransparentNoteScript ==. val s)
pure (txs, tNotes)
Nothing -> return []
-- | Add the transparent notes to the wallet
saveWalletTrNote ::
T.Text -- ^ the database path
-> (Entity ZcashTransaction, Entity TransparentNote)
-> WalletAddressId
-> IO ()
saveWalletTrNote dbPath (zt, tn) wa = do
let zT' = entityVal zt
PS.runSqlite dbPath $ do
t <-
upsert
(WalletTransaction
(zcashTransactionTxId zT')
(zcashTransactionBlock zT')
(zcashTransactionConf zT')
(zcashTransactionTime zT'))
[]
insert_ $
WalletTrNote
(entityKey t)
wa
(transparentNoteValue $ entityVal tn)
(entityKey tn)
False
2024-04-08 20:51:14 +00:00
-- | Find the Sapling notes that match the given spending key
findSaplingOutputs ::
T.Text -- ^ the database path
-> Int -- ^ the starting block
-> ZcashNetDB -- ^ The network
-> SaplingSpendingKeyDB -- ^ The spending key to trial decrypt
-> IO [(Entity ZcashTransaction, DecodedNote)]
findSaplingOutputs dbPath b znet sk = do
r <-
PS.runSqlite dbPath $ do
select $ do
(txs :& sOutputs) <-
from $ table @ZcashTransaction `innerJoin` table @ShieldOutput `on`
(\(txs :& sOutputs) ->
txs ^. ZcashTransactionId ==. sOutputs ^. ShieldOutputTx)
where_ (txs ^. ZcashTransactionBlock >. val b)
pure (txs, sOutputs)
let decryptedList =
map (saplingTrialDecrypt External (getNet znet)) r <>
map (saplingTrialDecrypt Internal (getNet znet)) r
return $ map (second fromJust) $ filter (\(z, n) -> isJust n) decryptedList
where
saplingTrialDecrypt ::
Scope
-> ZcashNet
-> (Entity ZcashTransaction, Entity ShieldOutput)
-> (Entity ZcashTransaction, Maybe DecodedNote)
saplingTrialDecrypt sc n (zt, so) = (zt, decodeShOut sc n so)
decodeShOut :: Scope -> ZcashNet -> Entity ShieldOutput -> Maybe DecodedNote
decodeShOut scope n s =
decodeSaplingOutputEsk
(getSapSK sk)
(ShieldedOutput
(getHex $ shieldOutputCv $ entityVal s)
(getHex $ shieldOutputCmu $ entityVal s)
(getHex $ shieldOutputEphKey $ entityVal s)
(getHex $ shieldOutputEncCipher $ entityVal s)
(getHex $ shieldOutputOutCipher $ entityVal s)
(getHex $ shieldOutputProof $ entityVal s))
n
scope
2024-04-07 14:25:25 +00:00
-- | Helper function to extract a Unified Address from the database
readUnifiedAddressDB :: WalletAddress -> Maybe UnifiedAddress
readUnifiedAddressDB =
isValidUnifiedAddress . TE.encodeUtf8 . getUA . walletAddressUAddress