423 lines
14 KiB
Haskell
423 lines
14 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
-- | Core wallet functionality for Zenith
|
|
module Zenith.Core where
|
|
|
|
import Control.Exception (throwIO, try)
|
|
import Data.Aeson
|
|
import Data.HexString (hexString)
|
|
import Data.Maybe (fromJust)
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Encoding as E
|
|
import Database.Persist
|
|
import Database.Persist.Sqlite
|
|
import Network.HTTP.Client
|
|
import ZcashHaskell.Keys
|
|
import ZcashHaskell.Orchard
|
|
( decryptOrchardActionSK
|
|
, encodeUnifiedAddress
|
|
, genOrchardReceiver
|
|
, genOrchardSpendingKey
|
|
, getOrchardNotePosition
|
|
, getOrchardWitness
|
|
, updateOrchardCommitmentTree
|
|
)
|
|
import ZcashHaskell.Sapling
|
|
( decodeSaplingOutputEsk
|
|
, genSaplingInternalAddress
|
|
, genSaplingPaymentAddress
|
|
, genSaplingSpendingKey
|
|
, getSaplingNotePosition
|
|
, getSaplingWitness
|
|
, updateSaplingCommitmentTree
|
|
)
|
|
import ZcashHaskell.Transparent (genTransparentPrvKey, genTransparentReceiver)
|
|
import ZcashHaskell.Types
|
|
import ZcashHaskell.Utils
|
|
import Zenith.DB
|
|
import Zenith.Types
|
|
( Config(..)
|
|
, HexStringDB(..)
|
|
, OrchardSpendingKeyDB(..)
|
|
, PhraseDB(..)
|
|
, SaplingSpendingKeyDB(..)
|
|
, ScopeDB(..)
|
|
, TransparentSpendingKeyDB(..)
|
|
, UnifiedAddressDB(..)
|
|
, ZcashNetDB(..)
|
|
, ZebraTreeInfo(..)
|
|
)
|
|
|
|
-- * Zebra Node interaction
|
|
-- | Checks the status of the `zebrad` node
|
|
checkZebra ::
|
|
T.Text -- ^ Host where `zebrad` is available
|
|
-> Int -- ^ Port where `zebrad` is available
|
|
-> IO ZebraGetInfo
|
|
checkZebra nodeHost nodePort = do
|
|
res <- makeZebraCall nodeHost nodePort "getinfo" []
|
|
case res of
|
|
Left e -> throwIO $ userError e
|
|
Right bi -> return bi
|
|
|
|
-- | Checks the status of the Zcash blockchain
|
|
checkBlockChain ::
|
|
T.Text -- ^ Host where `zebrad` is available
|
|
-> Int -- ^ Port where `zebrad` is available
|
|
-> IO ZebraGetBlockChainInfo
|
|
checkBlockChain nodeHost nodePort = do
|
|
r <- makeZebraCall nodeHost nodePort "getblockchaininfo" []
|
|
case r of
|
|
Left e -> throwIO $ userError e
|
|
Right bci -> return bci
|
|
|
|
-- | Get commitment trees from Zebra
|
|
getCommitmentTrees ::
|
|
T.Text -- ^ Host where `zebrad` is avaiable
|
|
-> Int -- ^ Port where `zebrad` is available
|
|
-> Int -- ^ Block height
|
|
-> IO ZebraTreeInfo
|
|
getCommitmentTrees nodeHost nodePort block = do
|
|
r <-
|
|
makeZebraCall
|
|
nodeHost
|
|
nodePort
|
|
"z_gettreestate"
|
|
[Data.Aeson.String $ T.pack $ show block]
|
|
case r of
|
|
Left e -> throwIO $ userError e
|
|
Right zti -> return zti
|
|
|
|
-- * Spending Keys
|
|
-- | Create an Orchard Spending Key for the given wallet and account index
|
|
createOrchardSpendingKey :: ZcashWallet -> Int -> IO OrchardSpendingKey
|
|
createOrchardSpendingKey zw i = do
|
|
let s = getWalletSeed $ getPhrase $ zcashWalletSeedPhrase zw
|
|
case s of
|
|
Nothing -> throwIO $ userError "Unable to generate seed"
|
|
Just s' -> do
|
|
let coinType =
|
|
case getNet $ zcashWalletNetwork zw of
|
|
MainNet -> MainNetCoin
|
|
TestNet -> TestNetCoin
|
|
RegTestNet -> RegTestNetCoin
|
|
let r = genOrchardSpendingKey s' coinType i
|
|
case r of
|
|
Nothing -> throwIO $ userError "Unable to generate Orchard spending key"
|
|
Just sk -> return sk
|
|
|
|
-- | Create a Sapling spending key for the given wallet and account index
|
|
createSaplingSpendingKey :: ZcashWallet -> Int -> IO SaplingSpendingKey
|
|
createSaplingSpendingKey zw i = do
|
|
let s = getWalletSeed $ getPhrase $ zcashWalletSeedPhrase zw
|
|
case s of
|
|
Nothing -> throwIO $ userError "Unable to generate seed"
|
|
Just s' -> do
|
|
let coinType =
|
|
case getNet $ zcashWalletNetwork zw of
|
|
MainNet -> MainNetCoin
|
|
TestNet -> TestNetCoin
|
|
RegTestNet -> RegTestNetCoin
|
|
let r = genSaplingSpendingKey s' coinType i
|
|
case r of
|
|
Nothing -> throwIO $ userError "Unable to generate Sapling spending key"
|
|
Just sk -> return sk
|
|
|
|
createTransparentSpendingKey :: ZcashWallet -> Int -> IO TransparentSpendingKey
|
|
createTransparentSpendingKey zw i = do
|
|
let s = getWalletSeed $ getPhrase $ zcashWalletSeedPhrase zw
|
|
case s of
|
|
Nothing -> throwIO $ userError "Unable to generate seed"
|
|
Just s' -> do
|
|
let coinType =
|
|
case getNet $ zcashWalletNetwork zw of
|
|
MainNet -> MainNetCoin
|
|
TestNet -> TestNetCoin
|
|
RegTestNet -> RegTestNetCoin
|
|
genTransparentPrvKey s' coinType i
|
|
|
|
-- * Accounts
|
|
-- | Create an account for the given wallet and account index
|
|
createZcashAccount ::
|
|
T.Text -- ^ The account's name
|
|
-> Int -- ^ The account's index
|
|
-> Entity ZcashWallet -- ^ The Zcash wallet that this account will be attached to
|
|
-> IO ZcashAccount
|
|
createZcashAccount n i zw = do
|
|
orSk <- createOrchardSpendingKey (entityVal zw) i
|
|
sapSk <- createSaplingSpendingKey (entityVal zw) i
|
|
tSk <- createTransparentSpendingKey (entityVal zw) i
|
|
return $
|
|
ZcashAccount
|
|
i
|
|
(entityKey zw)
|
|
n
|
|
(OrchardSpendingKeyDB orSk)
|
|
(SaplingSpendingKeyDB sapSk)
|
|
(TransparentSpendingKeyDB tSk)
|
|
|
|
-- * Addresses
|
|
-- | Create an external unified address for the given account and index
|
|
createWalletAddress ::
|
|
T.Text -- ^ The address nickname
|
|
-> Int -- ^ The address' index
|
|
-> ZcashNet -- ^ The network for this address
|
|
-> Scope -- ^ External or Internal
|
|
-> Entity ZcashAccount -- ^ The Zcash account that the address will be attached to
|
|
-> IO WalletAddress
|
|
createWalletAddress n i zNet scope za = do
|
|
let oRec =
|
|
genOrchardReceiver i scope $
|
|
getOrchSK $ zcashAccountOrchSpendKey $ entityVal za
|
|
let sRec =
|
|
case scope of
|
|
External ->
|
|
genSaplingPaymentAddress i $
|
|
getSapSK $ zcashAccountSapSpendKey $ entityVal za
|
|
Internal ->
|
|
genSaplingInternalAddress $
|
|
getSapSK $ zcashAccountSapSpendKey $ entityVal za
|
|
tRec <-
|
|
genTransparentReceiver i scope $
|
|
getTranSK $ zcashAccountTPrivateKey $ entityVal za
|
|
return $
|
|
WalletAddress
|
|
i
|
|
(entityKey za)
|
|
n
|
|
(UnifiedAddressDB $
|
|
encodeUnifiedAddress $ UnifiedAddress zNet oRec sRec (Just tRec))
|
|
(ScopeDB scope)
|
|
|
|
-- * Wallet
|
|
-- | Find the Sapling notes that match the given spending key
|
|
findSaplingOutputs ::
|
|
Config -- ^ the configuration parameters
|
|
-> Int -- ^ the starting block
|
|
-> ZcashNetDB -- ^ The network
|
|
-> Entity ZcashAccount -- ^ The account to use
|
|
-> IO ()
|
|
findSaplingOutputs config b znet za = do
|
|
let dbPath = c_dbPath config
|
|
let zebraHost = c_zebraHost config
|
|
let zebraPort = c_zebraPort config
|
|
let zn = getNet znet
|
|
tList <- getShieldedOutputs dbPath 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
|
|
where
|
|
sk :: SaplingSpendingKeyDB
|
|
sk = zcashAccountSapSpendKey $ entityVal za
|
|
decryptNotes ::
|
|
SaplingCommitmentTree
|
|
-> ZcashNet
|
|
-> [(Entity ZcashTransaction, Entity ShieldOutput)]
|
|
-> IO ()
|
|
decryptNotes _ _ [] = return ()
|
|
decryptNotes st n ((zt, o):txs) = do
|
|
let updatedTree =
|
|
updateSaplingCommitmentTree
|
|
st
|
|
(getHex $ shieldOutputCmu $ entityVal o)
|
|
case updatedTree of
|
|
Nothing -> throwIO $ userError "Failed to update commitment tree"
|
|
Just uT -> do
|
|
let noteWitness = getSaplingWitness uT
|
|
let notePos = getSaplingNotePosition <$> noteWitness
|
|
case notePos of
|
|
Nothing -> throwIO $ userError "Failed to obtain note position"
|
|
Just nP -> do
|
|
case decodeShOut External n nP o of
|
|
Nothing -> do
|
|
case decodeShOut Internal n nP o of
|
|
Nothing -> do
|
|
decryptNotes uT n txs
|
|
Just dn1 -> do
|
|
print dn1
|
|
wId <-
|
|
saveWalletTransaction
|
|
(c_dbPath config)
|
|
(entityKey za)
|
|
zt
|
|
saveWalletSapNote
|
|
(c_dbPath config)
|
|
wId
|
|
nP
|
|
(fromJust noteWitness)
|
|
True
|
|
(entityKey za)
|
|
dn1
|
|
decryptNotes uT n txs
|
|
Just dn0 -> do
|
|
print dn0
|
|
wId <-
|
|
saveWalletTransaction (c_dbPath config) (entityKey za) zt
|
|
saveWalletSapNote
|
|
(c_dbPath config)
|
|
wId
|
|
nP
|
|
(fromJust noteWitness)
|
|
False
|
|
(entityKey za)
|
|
dn0
|
|
decryptNotes uT n txs
|
|
decodeShOut ::
|
|
Scope
|
|
-> ZcashNet
|
|
-> Integer
|
|
-> Entity ShieldOutput
|
|
-> Maybe DecodedNote
|
|
decodeShOut scope n pos s = do
|
|
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
|
|
pos
|
|
|
|
-- | Get Orchard actions
|
|
findOrchardActions ::
|
|
Config -- ^ the configuration parameters
|
|
-> Int -- ^ the starting block
|
|
-> ZcashNetDB -- ^ The network
|
|
-> Entity ZcashAccount -- ^ The account to use
|
|
-> IO ()
|
|
findOrchardActions config b znet za = do
|
|
let dbPath = c_dbPath config
|
|
let zebraHost = c_zebraHost config
|
|
let zebraPort = c_zebraPort config
|
|
let zn = getNet znet
|
|
tList <- getOrchardActions dbPath 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
|
|
where
|
|
decryptNotes ::
|
|
OrchardCommitmentTree
|
|
-> ZcashNet
|
|
-> [(Entity ZcashTransaction, Entity OrchAction)]
|
|
-> IO ()
|
|
decryptNotes _ _ [] = return ()
|
|
decryptNotes ot n ((zt, o):txs) = do
|
|
let updatedTree =
|
|
updateOrchardCommitmentTree
|
|
ot
|
|
(getHex $ orchActionCmx $ entityVal o)
|
|
case updatedTree of
|
|
Nothing -> throwIO $ userError "Failed to update commitment tree"
|
|
Just uT -> do
|
|
let noteWitness = getOrchardWitness uT
|
|
let notePos = getOrchardNotePosition <$> noteWitness
|
|
case notePos of
|
|
Nothing -> throwIO $ userError "Failed to obtain note position"
|
|
Just nP ->
|
|
case decodeOrchAction External nP o of
|
|
Nothing ->
|
|
case decodeOrchAction Internal nP o of
|
|
Nothing -> decryptNotes uT n txs
|
|
Just dn1 -> do
|
|
print dn1
|
|
wId <-
|
|
saveWalletTransaction
|
|
(c_dbPath config)
|
|
(entityKey za)
|
|
zt
|
|
saveWalletOrchNote
|
|
(c_dbPath config)
|
|
wId
|
|
nP
|
|
(fromJust noteWitness)
|
|
True
|
|
(entityKey za)
|
|
dn1
|
|
decryptNotes uT n txs
|
|
Just dn -> do
|
|
print dn
|
|
wId <-
|
|
saveWalletTransaction (c_dbPath config) (entityKey za) zt
|
|
saveWalletOrchNote
|
|
(c_dbPath config)
|
|
wId
|
|
nP
|
|
(fromJust noteWitness)
|
|
False
|
|
(entityKey za)
|
|
dn
|
|
decryptNotes uT n txs
|
|
sk :: OrchardSpendingKeyDB
|
|
sk = zcashAccountOrchSpendKey $ entityVal za
|
|
decodeOrchAction ::
|
|
Scope -> Integer -> Entity OrchAction -> Maybe DecodedNote
|
|
decodeOrchAction scope pos o =
|
|
decryptOrchardActionSK (getOrchSK sk) scope $
|
|
OrchardAction
|
|
(getHex $ orchActionNf $ entityVal o)
|
|
(getHex $ orchActionRk $ entityVal o)
|
|
(getHex $ orchActionCmx $ entityVal o)
|
|
(getHex $ orchActionEphKey $ entityVal o)
|
|
(getHex $ orchActionEncCipher $ entityVal o)
|
|
(getHex $ orchActionOutCipher $ entityVal o)
|
|
(getHex $ orchActionCv $ entityVal o)
|
|
(getHex $ orchActionAuth $ entityVal o)
|
|
|
|
-- | Sync the wallet with the data store
|
|
syncWallet ::
|
|
Config -- ^ configuration parameters
|
|
-> Entity ZcashWallet
|
|
-> IO String
|
|
syncWallet config w = do
|
|
let walletDb = c_dbPath config
|
|
accs <- getAccounts walletDb $ entityKey w
|
|
addrs <- concat <$> mapM (getAddresses walletDb . entityKey) accs
|
|
intAddrs <- concat <$> mapM (getInternalAddresses walletDb . entityKey) accs
|
|
chainTip <- getMaxBlock walletDb
|
|
let lastBlock = zcashWalletLastSync $ entityVal w
|
|
let startBlock =
|
|
if lastBlock > 0
|
|
then lastBlock
|
|
else zcashWalletBirthdayHeight $ entityVal w
|
|
mapM_ (findTransparentNotes walletDb startBlock) addrs
|
|
mapM_ (findTransparentNotes walletDb startBlock) intAddrs
|
|
mapM_ (findTransparentSpends walletDb . entityKey) accs
|
|
sapNotes <-
|
|
mapM
|
|
(findSaplingOutputs config startBlock (zcashWalletNetwork $ entityVal w))
|
|
accs
|
|
orchNotes <-
|
|
mapM
|
|
(findOrchardActions config startBlock (zcashWalletNetwork $ entityVal w))
|
|
accs
|
|
updateWalletSync walletDb chainTip (entityKey w)
|
|
mapM_ (getWalletTransactions walletDb) addrs
|
|
return "Testing"
|
|
|
|
testSync :: Config -> IO ()
|
|
testSync config = do
|
|
let dbPath = c_dbPath config
|
|
_ <- initDb dbPath
|
|
w <- getWallets dbPath TestNet
|
|
r <- mapM (syncWallet config) w
|
|
print r
|
|
|
|
clearSync :: Config -> IO ()
|
|
clearSync config = do
|
|
let dbPath = c_dbPath config
|
|
_ <- initDb dbPath
|
|
_ <- clearWalletTransactions dbPath
|
|
w <- getWallets dbPath TestNet
|
|
mapM_ (updateWalletSync dbPath 0 . entityKey) w
|
|
w' <- getWallets dbPath TestNet
|
|
r <- mapM (syncWallet config) w'
|
|
print r
|