1429 lines
51 KiB
Haskell
1429 lines
51 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
-- | Core wallet functionality for Zenith
|
|
module Zenith.Core where
|
|
|
|
import Control.Exception (throwIO, try)
|
|
import Control.Monad (forM, unless, when)
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import Control.Monad.Logger
|
|
( LoggingT
|
|
, MonadLoggerIO
|
|
, NoLoggingT
|
|
, logDebugN
|
|
, logErrorN
|
|
, logInfoN
|
|
, logWarnN
|
|
, runFileLoggingT
|
|
, runNoLoggingT
|
|
, runStdoutLoggingT
|
|
)
|
|
import Crypto.Secp256k1 (SecKey(..))
|
|
import Data.Aeson
|
|
import Data.Binary.Get hiding (getBytes)
|
|
import qualified Data.ByteString as BS
|
|
import qualified Data.ByteString.Lazy as LBS
|
|
import Data.HexString (HexString, toBytes, toText)
|
|
import Data.Int (Int64)
|
|
import Data.List
|
|
import Data.Maybe (fromJust, fromMaybe)
|
|
import Data.Scientific (Scientific, scientific, toBoundedInteger)
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Encoding as E
|
|
import Data.Time
|
|
import qualified Database.Esqueleto.Experimental as ESQ
|
|
import Database.Persist
|
|
import Database.Persist.Sqlite
|
|
import GHC.Float.RealFracMethods
|
|
( ceilingFloatInteger
|
|
, floorFloatInt
|
|
, floorFloatInteger
|
|
)
|
|
import Haskoin.Crypto.Keys (XPrvKey(..))
|
|
import Lens.Micro ((&), (.~), (^.), set)
|
|
import Network.HTTP.Client
|
|
import ZcashHaskell.Keys
|
|
import ZcashHaskell.Orchard
|
|
( decryptOrchardActionSK
|
|
, encodeUnifiedAddress
|
|
, genOrchardReceiver
|
|
, genOrchardSpendingKey
|
|
, getOrchardFrontier
|
|
, getOrchardNotePosition
|
|
, getOrchardWitness
|
|
, isValidUnifiedAddress
|
|
, updateOrchardCommitmentTree
|
|
, updateOrchardWitness
|
|
)
|
|
import ZcashHaskell.Sapling
|
|
( decodeSaplingOutputEsk
|
|
, genSaplingInternalAddress
|
|
, genSaplingPaymentAddress
|
|
, genSaplingSpendingKey
|
|
, getSaplingFrontier
|
|
, getSaplingNotePosition
|
|
, getSaplingWitness
|
|
, updateSaplingCommitmentTree
|
|
, updateSaplingWitness
|
|
)
|
|
import ZcashHaskell.Transparent
|
|
( genTransparentPrvKey
|
|
, genTransparentReceiver
|
|
, genTransparentSecretKey
|
|
)
|
|
import ZcashHaskell.Types
|
|
import ZcashHaskell.Utils
|
|
import Zenith.DB
|
|
import Zenith.Types
|
|
( Config(..)
|
|
, HexStringDB(..)
|
|
, OrchardSpendingKeyDB(..)
|
|
, PhraseDB(..)
|
|
, PrivacyPolicy(..)
|
|
, ProposedNote(..)
|
|
, RseedDB(..)
|
|
, SaplingSpendingKeyDB(..)
|
|
, ScopeDB(..)
|
|
, TransparentSpendingKeyDB(..)
|
|
, UnifiedAddressDB(..)
|
|
, ValidAddressAPI(..)
|
|
, 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 ::
|
|
ConnectionPool
|
|
-> T.Text -- ^ Host where `zebrad` is avaiable
|
|
-> Int -- ^ Port where `zebrad` is available
|
|
-> ZcashNetDB
|
|
-> Int -- ^ Block height
|
|
-> IO ZebraTreeInfo
|
|
getCommitmentTrees pool nodeHost nodePort znet block = do
|
|
bh' <- getBlockHash pool block znet
|
|
case bh' of
|
|
Nothing -> 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
|
|
Just bh -> do
|
|
r <-
|
|
makeZebraCall
|
|
nodeHost
|
|
nodePort
|
|
"z_gettreestate"
|
|
[Data.Aeson.String $ toText bh]
|
|
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)
|
|
|
|
-- | Create an external unified address for the given account and index with custom receivers
|
|
createCustomWalletAddress ::
|
|
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
|
|
-> Bool -- ^ Exclude Sapling
|
|
-> Bool -- ^ Exclude Transparent
|
|
-> IO WalletAddress
|
|
createCustomWalletAddress n i zNet scope za exSap exTr = do
|
|
let oRec =
|
|
genOrchardReceiver i scope $
|
|
getOrchSK $ zcashAccountOrchSpendKey $ entityVal za
|
|
let sRec =
|
|
if exSap
|
|
then Nothing
|
|
else case scope of
|
|
External ->
|
|
genSaplingPaymentAddress i $
|
|
getSapSK $ zcashAccountSapSpendKey $ entityVal za
|
|
Internal ->
|
|
genSaplingInternalAddress $
|
|
getSapSK $ zcashAccountSapSpendKey $ entityVal za
|
|
tRec <-
|
|
if exTr
|
|
then return Nothing
|
|
else Just <$>
|
|
genTransparentReceiver
|
|
i
|
|
scope
|
|
(getTranSK $ zcashAccountTPrivateKey $ entityVal za)
|
|
return $
|
|
WalletAddress
|
|
i
|
|
(entityKey za)
|
|
n
|
|
(UnifiedAddressDB $
|
|
encodeUnifiedAddress $ UnifiedAddress zNet oRec sRec 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
|
|
-> NoLoggingT 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
|
|
pool <- liftIO $ runNoLoggingT $ initPool dbPath
|
|
tList <- liftIO $ getShieldedOutputs pool b znet
|
|
trees <- liftIO $ getCommitmentTrees pool zebraHost zebraPort znet (b - 1)
|
|
logDebugN "getting Sapling frontier"
|
|
let sT = getSaplingFrontier $ SaplingCommitmentTree $ ztiSapling trees
|
|
case sT of
|
|
Nothing ->
|
|
liftIO $ throwIO $ userError "Failed to read Sapling commitment tree"
|
|
Just sT' -> do
|
|
logDebugN "Sapling frontier valid"
|
|
decryptNotes sT' zn pool tList
|
|
sapNotes <- liftIO $ getWalletSapNotes pool (entityKey za)
|
|
liftIO $ findSapSpends pool (entityKey za) sapNotes
|
|
where
|
|
sk :: SaplingSpendingKeyDB
|
|
sk = zcashAccountSapSpendKey $ entityVal za
|
|
decryptNotes ::
|
|
SaplingFrontier
|
|
-> ZcashNet
|
|
-> ConnectionPool
|
|
-> [(Entity ZcashTransaction, Entity ShieldOutput)]
|
|
-> NoLoggingT IO ()
|
|
decryptNotes _ _ _ [] = return ()
|
|
decryptNotes st n pool ((zt, o):txs) = do
|
|
let updatedTree =
|
|
updateSaplingCommitmentTree
|
|
st
|
|
(getHex $ shieldOutputCmu $ entityVal o)
|
|
logDebugN "updated frontier"
|
|
case updatedTree of
|
|
Nothing ->
|
|
liftIO $ throwIO $ userError "Failed to update commitment tree"
|
|
Just uT -> do
|
|
let noteWitness = getSaplingWitness uT
|
|
logDebugN "got witness"
|
|
let notePos = getSaplingNotePosition <$> noteWitness
|
|
logDebugN "got position"
|
|
case notePos of
|
|
Nothing ->
|
|
liftIO $ throwIO $ userError "Failed to obtain note position"
|
|
Just nP -> do
|
|
case decodeShOut External n nP o of
|
|
Nothing -> do
|
|
logDebugN "couldn't decode external"
|
|
case decodeShOut Internal n nP o of
|
|
Nothing -> do
|
|
logDebugN "couldn't decode internal"
|
|
decryptNotes uT n pool txs
|
|
Just dn1 -> do
|
|
wId <-
|
|
liftIO $ saveWalletTransaction pool (entityKey za) zt
|
|
liftIO $
|
|
saveWalletSapNote
|
|
pool
|
|
wId
|
|
nP
|
|
(fromJust noteWitness)
|
|
True
|
|
(entityKey za)
|
|
(entityKey o)
|
|
dn1
|
|
decryptNotes uT n pool txs
|
|
Just dn0 -> do
|
|
wId <- liftIO $ saveWalletTransaction pool (entityKey za) zt
|
|
liftIO $
|
|
saveWalletSapNote
|
|
pool
|
|
wId
|
|
nP
|
|
(fromJust noteWitness)
|
|
False
|
|
(entityKey za)
|
|
(entityKey o)
|
|
dn0
|
|
decryptNotes uT n pool 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
|
|
pool <- runNoLoggingT $ initPool dbPath
|
|
tList <- getOrchardActions pool b znet
|
|
trees <- getCommitmentTrees pool zebraHost zebraPort znet (b - 1)
|
|
let sT = getOrchardFrontier $ OrchardCommitmentTree $ ztiOrchard trees
|
|
case sT of
|
|
Nothing -> throwIO $ userError "Failed to read Orchard commitment tree"
|
|
Just sT' -> do
|
|
decryptNotes sT' zn pool tList
|
|
orchNotes <- getWalletOrchNotes pool (entityKey za)
|
|
findOrchSpends pool (entityKey za) orchNotes
|
|
where
|
|
decryptNotes ::
|
|
OrchardFrontier
|
|
-> ZcashNet
|
|
-> ConnectionPool
|
|
-> [(Entity ZcashTransaction, Entity OrchAction)]
|
|
-> IO ()
|
|
decryptNotes _ _ _ [] = return ()
|
|
decryptNotes ot n pool ((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 pool txs
|
|
Just dn1 -> do
|
|
wId <- saveWalletTransaction pool (entityKey za) zt
|
|
saveWalletOrchNote
|
|
pool
|
|
wId
|
|
nP
|
|
(fromJust noteWitness)
|
|
True
|
|
(entityKey za)
|
|
(entityKey o)
|
|
dn1
|
|
decryptNotes uT n pool txs
|
|
Just dn -> do
|
|
wId <- saveWalletTransaction pool (entityKey za) zt
|
|
saveWalletOrchNote
|
|
pool
|
|
wId
|
|
nP
|
|
(fromJust noteWitness)
|
|
False
|
|
(entityKey za)
|
|
(entityKey o)
|
|
dn
|
|
decryptNotes uT n pool 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)
|
|
|
|
updateSaplingWitnesses :: ConnectionPool -> IO ()
|
|
updateSaplingWitnesses pool = do
|
|
sapNotes <- getUnspentSapNotes pool
|
|
maxId <- liftIO $ getMaxSaplingNote pool
|
|
mapM_ (updateOneNote maxId) sapNotes
|
|
where
|
|
updateOneNote :: ShieldOutputId -> Entity WalletSapNote -> IO ()
|
|
updateOneNote maxId n = do
|
|
let noteSync = walletSapNoteWitPos $ entityVal n
|
|
when (noteSync < maxId) $ do
|
|
cmus <- liftIO $ getSaplingCmus pool noteSync maxId
|
|
let cmuList = map (\(ESQ.Value x) -> getHex x) cmus
|
|
let newWitness =
|
|
updateSaplingWitness
|
|
(SaplingWitness $ getHex $ walletSapNoteWitness $ entityVal n)
|
|
cmuList
|
|
liftIO $ updateSapNoteRecord pool (entityKey n) newWitness maxId
|
|
|
|
updateOrchardWitnesses :: ConnectionPool -> IO ()
|
|
updateOrchardWitnesses pool = do
|
|
orchNotes <- getUnspentOrchNotes pool
|
|
maxId <- getMaxOrchardNote pool
|
|
mapM_ (updateOneNote maxId) orchNotes
|
|
where
|
|
updateOneNote :: OrchActionId -> Entity WalletOrchNote -> IO ()
|
|
updateOneNote maxId n = do
|
|
let noteSync = walletOrchNoteWitPos $ entityVal n
|
|
when (noteSync < maxId) $ do
|
|
cmxs <- liftIO $ getOrchardCmxs pool noteSync maxId
|
|
let cmxList = map (\(ESQ.Value x) -> getHex x) cmxs
|
|
let newWitness =
|
|
updateOrchardWitness
|
|
(OrchardWitness $ getHex $ walletOrchNoteWitness $ entityVal n)
|
|
cmxList
|
|
liftIO $ updateOrchNoteRecord pool (entityKey n) newWitness maxId
|
|
|
|
-- | Calculate fee per ZIP-317
|
|
calculateTxFee ::
|
|
([Entity WalletTrNote], [Entity WalletSapNote], [Entity WalletOrchNote])
|
|
-> Int
|
|
-> Integer
|
|
calculateTxFee (t, s, o) i =
|
|
fromIntegral
|
|
(5000 * (max (length t) tout + max (length s) sout + length o + oout))
|
|
where
|
|
tout =
|
|
if i == 1 || i == 2
|
|
then 1
|
|
else 0
|
|
sout =
|
|
if i == 3
|
|
then 1
|
|
else 0
|
|
oout =
|
|
if i == 4
|
|
then 1
|
|
else 0
|
|
|
|
-- | Prepare a transaction for sending
|
|
prepareTx ::
|
|
ConnectionPool
|
|
-> T.Text
|
|
-> Int
|
|
-> ZcashNet
|
|
-> ZcashAccountId
|
|
-> Int
|
|
-> Scientific
|
|
-> UnifiedAddress
|
|
-> T.Text
|
|
-> LoggingT IO (Either TxError HexString)
|
|
prepareTx pool zebraHost zebraPort zn za bh amt ua memo = do
|
|
accRead <- liftIO $ getAccountById pool za
|
|
let recipient =
|
|
case o_rec ua of
|
|
Nothing ->
|
|
case s_rec ua of
|
|
Nothing ->
|
|
case t_rec ua of
|
|
Nothing -> (0, "")
|
|
Just r3 ->
|
|
case tr_type r3 of
|
|
P2PKH -> (1, toBytes $ tr_bytes r3)
|
|
P2SH -> (2, toBytes $ tr_bytes r3)
|
|
Just r2 -> (3, getBytes r2)
|
|
Just r1 -> (4, getBytes r1)
|
|
logDebugN $ T.pack $ show recipient
|
|
logDebugN $ T.pack $ "Target block: " ++ show bh
|
|
trees <-
|
|
liftIO $ getCommitmentTrees pool zebraHost zebraPort (ZcashNetDB zn) bh
|
|
let sT = SaplingCommitmentTree $ ztiSapling trees
|
|
let oT = OrchardCommitmentTree $ ztiOrchard trees
|
|
case accRead of
|
|
Nothing -> do
|
|
logErrorN "Can't find Account"
|
|
return $ Left ZHError
|
|
Just acc -> do
|
|
logDebugN $ T.pack $ show acc
|
|
let zats' = toBoundedInteger $ amt * scientific 1 8
|
|
case zats' of
|
|
Nothing -> return $ Left ZHError
|
|
Just zats -> do
|
|
logDebugN $ T.pack $ show (zats :: Int64)
|
|
{-firstPass <- liftIO $ selectUnspentNotes pool za zats-}
|
|
--let fee = calculateTxFee firstPass $ fst recipient
|
|
--logDebugN $ T.pack $ "calculated fee " ++ show fee
|
|
(tList, sList, oList) <-
|
|
liftIO $ selectUnspentNotes pool za (fromIntegral $ zats + 5000)
|
|
logDebugN "selected notes"
|
|
logDebugN $ T.pack $ show tList
|
|
logDebugN $ T.pack $ show sList
|
|
logDebugN $ T.pack $ show oList
|
|
let noteTotal = getTotalAmount (tList, sList, oList)
|
|
tSpends <-
|
|
liftIO $
|
|
prepTSpends
|
|
(getTranSK $ zcashAccountTPrivateKey $ entityVal acc)
|
|
tList
|
|
--print tSpends
|
|
sSpends <-
|
|
liftIO $
|
|
prepSSpends
|
|
(getSapSK $ zcashAccountSapSpendKey $ entityVal acc)
|
|
sList
|
|
--print sSpends
|
|
oSpends <-
|
|
liftIO $
|
|
prepOSpends
|
|
(getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc)
|
|
oList
|
|
--print oSpends
|
|
dummy <-
|
|
liftIO $
|
|
makeOutgoing
|
|
acc
|
|
recipient
|
|
zats
|
|
(fromInteger noteTotal - 5000 - zats)
|
|
logDebugN "Calculating fee"
|
|
let feeResponse =
|
|
createTransaction
|
|
(Just sT)
|
|
(Just oT)
|
|
tSpends
|
|
sSpends
|
|
oSpends
|
|
dummy
|
|
zn
|
|
bh
|
|
False
|
|
case feeResponse of
|
|
Left e1 -> return $ Left Fee
|
|
Right fee -> do
|
|
let feeAmt =
|
|
fromIntegral
|
|
(runGet getInt64le $ LBS.fromStrict $ toBytes fee)
|
|
(tList1, sList1, oList1) <-
|
|
liftIO $ selectUnspentNotes pool za (fromIntegral zats + feeAmt)
|
|
logDebugN $ T.pack $ "selected notes with fee" ++ show feeAmt
|
|
logDebugN $ T.pack $ show tList
|
|
logDebugN $ T.pack $ show sList
|
|
logDebugN $ T.pack $ show oList
|
|
outgoing <-
|
|
liftIO $
|
|
makeOutgoing
|
|
acc
|
|
recipient
|
|
zats
|
|
(fromInteger noteTotal - fromInteger feeAmt - zats)
|
|
logDebugN $ T.pack $ show outgoing
|
|
let tx =
|
|
createTransaction
|
|
(Just sT)
|
|
(Just oT)
|
|
tSpends
|
|
sSpends
|
|
oSpends
|
|
outgoing
|
|
zn
|
|
bh
|
|
True
|
|
logDebugN $ T.pack $ show tx
|
|
return tx
|
|
where
|
|
makeOutgoing ::
|
|
Entity ZcashAccount
|
|
-> (Int, BS.ByteString)
|
|
-> Int64
|
|
-> Int64
|
|
-> IO [OutgoingNote]
|
|
makeOutgoing acc (k, recvr) zats chg = do
|
|
chgAddr <- runNoLoggingT $ getInternalAddresses pool $ entityKey acc
|
|
let internalUA = getUA $ walletAddressUAddress $ entityVal $ head chgAddr
|
|
let chgRcvr =
|
|
fromJust $ o_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA)
|
|
return
|
|
[ OutgoingNote
|
|
4
|
|
(getBytes $ getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc)
|
|
(getBytes chgRcvr)
|
|
(fromIntegral chg)
|
|
""
|
|
True
|
|
, OutgoingNote
|
|
(fromIntegral k)
|
|
(case k of
|
|
4 ->
|
|
getBytes $ getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc
|
|
3 ->
|
|
getBytes $ getSapSK $ zcashAccountSapSpendKey $ entityVal acc
|
|
_ -> "")
|
|
recvr
|
|
(fromIntegral zats)
|
|
(E.encodeUtf8 memo)
|
|
False
|
|
]
|
|
getTotalAmount ::
|
|
( [Entity WalletTrNote]
|
|
, [Entity WalletSapNote]
|
|
, [Entity WalletOrchNote])
|
|
-> Integer
|
|
getTotalAmount (t, s, o) =
|
|
sum (map (fromIntegral . walletTrNoteValue . entityVal) t) +
|
|
sum (map (fromIntegral . walletSapNoteValue . entityVal) s) +
|
|
sum (map (fromIntegral . walletOrchNoteValue . entityVal) o)
|
|
prepTSpends ::
|
|
TransparentSpendingKey
|
|
-> [Entity WalletTrNote]
|
|
-> IO [TransparentTxSpend]
|
|
prepTSpends sk notes = do
|
|
forM notes $ \n -> do
|
|
tAddRead <- getAddressById pool $ walletTrNoteAddress $ entityVal n
|
|
case tAddRead of
|
|
Nothing -> throwIO $ userError "Couldn't read t-address"
|
|
Just tAdd -> do
|
|
(XPrvKey _ _ _ _ (SecKey xp_key)) <-
|
|
genTransparentSecretKey
|
|
(walletAddressIndex $ entityVal tAdd)
|
|
(getScope $ walletAddressScope $ entityVal tAdd)
|
|
sk
|
|
mReverseTxId <- getWalletTxId pool $ walletTrNoteTx $ entityVal n
|
|
case mReverseTxId of
|
|
Nothing -> throwIO $ userError "failed to get tx ID"
|
|
Just (ESQ.Value reverseTxId) -> do
|
|
let flipTxId = BS.reverse $ toBytes $ getHex reverseTxId
|
|
return $
|
|
TransparentTxSpend
|
|
xp_key
|
|
(RawOutPoint
|
|
flipTxId
|
|
(fromIntegral $ walletTrNotePosition $ entityVal n))
|
|
(RawTxOut
|
|
(fromIntegral $ walletTrNoteValue $ entityVal n)
|
|
(walletTrNoteScript $ entityVal n))
|
|
prepSSpends ::
|
|
SaplingSpendingKey -> [Entity WalletSapNote] -> IO [SaplingTxSpend]
|
|
prepSSpends sk notes = do
|
|
forM notes $ \n -> do
|
|
return $
|
|
SaplingTxSpend
|
|
(getBytes sk)
|
|
(DecodedNote
|
|
(fromIntegral $ walletSapNoteValue $ entityVal n)
|
|
(walletSapNoteRecipient $ entityVal n)
|
|
(E.encodeUtf8 $ walletSapNoteMemo $ entityVal n)
|
|
(getHex $ walletSapNoteNullifier $ entityVal n)
|
|
""
|
|
(getRseed $ walletSapNoteRseed $ entityVal n))
|
|
(toBytes $ getHex $ walletSapNoteWitness $ entityVal n)
|
|
prepOSpends ::
|
|
OrchardSpendingKey -> [Entity WalletOrchNote] -> IO [OrchardTxSpend]
|
|
prepOSpends sk notes = do
|
|
forM notes $ \n -> do
|
|
return $
|
|
OrchardTxSpend
|
|
(getBytes sk)
|
|
(DecodedNote
|
|
(fromIntegral $ walletOrchNoteValue $ entityVal n)
|
|
(walletOrchNoteRecipient $ entityVal n)
|
|
(E.encodeUtf8 $ walletOrchNoteMemo $ entityVal n)
|
|
(getHex $ walletOrchNoteNullifier $ entityVal n)
|
|
(walletOrchNoteRho $ entityVal n)
|
|
(getRseed $ walletOrchNoteRseed $ entityVal n))
|
|
(toBytes $ getHex $ walletOrchNoteWitness $ entityVal n)
|
|
sapAnchor :: [Entity WalletSapNote] -> Maybe SaplingWitness
|
|
sapAnchor notes =
|
|
if not (null notes)
|
|
then Just $
|
|
SaplingWitness $
|
|
getHex $ walletSapNoteWitness $ entityVal $ head notes
|
|
else Nothing
|
|
orchAnchor :: [Entity WalletOrchNote] -> Maybe OrchardWitness
|
|
orchAnchor notes =
|
|
if not (null notes)
|
|
then Just $
|
|
OrchardWitness $
|
|
getHex $ walletOrchNoteWitness $ entityVal $ head notes
|
|
else Nothing
|
|
|
|
deshieldNotes ::
|
|
ConnectionPool
|
|
-> T.Text
|
|
-> Int
|
|
-> ZcashNet
|
|
-> ZcashAccountId
|
|
-> Int
|
|
-> ProposedNote
|
|
-> LoggingT IO (Either TxError HexString)
|
|
deshieldNotes pool zebraHost zebraPort znet za bh pnote = do
|
|
bal <- liftIO $ getShieldedBalance pool za
|
|
let zats = pn_amt pnote * scientific 1 8
|
|
if fromInteger bal > (scientific 2 4 + zats)
|
|
then prepareTxV2 pool zebraHost zebraPort znet za bh [pnote] Low
|
|
else return $ Left InsufficientFunds
|
|
|
|
shieldTransparentNotes ::
|
|
ConnectionPool
|
|
-> T.Text
|
|
-> Int
|
|
-> ZcashNet
|
|
-> ZcashAccountId
|
|
-> Int
|
|
-> NoLoggingT IO [Either TxError HexString]
|
|
shieldTransparentNotes pool zebraHost zebraPort znet za bh = do
|
|
accRead <- liftIO $ getAccountById pool za
|
|
logDebugN $ T.pack $ "Target block: " ++ show bh
|
|
{-
|
|
-trees <- liftIO $ getCommitmentTrees zebraHost zebraPort bh
|
|
-let sT = SaplingCommitmentTree $ ztiSapling trees
|
|
-let oT = OrchardCommitmentTree $ ztiOrchard trees
|
|
-}
|
|
case accRead of
|
|
Nothing -> do
|
|
logErrorN "Can't find Account"
|
|
return [Left ZHError]
|
|
Just acc -> do
|
|
trNotes' <- liftIO $ getWalletUnspentTrNotes pool za
|
|
dRecvs <- liftIO $ getReceivers pool trNotes'
|
|
let fNotes =
|
|
map
|
|
(\x ->
|
|
filter (\y -> walletTrNoteAddress (entityVal y) == x) trNotes')
|
|
dRecvs
|
|
forM fNotes $ \trNotes -> do
|
|
let noteTotal = getTotalAmount (trNotes, [], [])
|
|
tSpends <-
|
|
liftIO $
|
|
prepTSpends
|
|
(getTranSK $ zcashAccountTPrivateKey $ entityVal acc)
|
|
trNotes
|
|
chgAddr <- getInternalAddresses pool $ entityKey acc
|
|
let internalUA =
|
|
getUA $ walletAddressUAddress $ entityVal $ head chgAddr
|
|
let oRcvr =
|
|
fromJust $
|
|
o_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA)
|
|
let dummy =
|
|
OutgoingNote
|
|
4
|
|
(getBytes $ getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc)
|
|
(getBytes oRcvr)
|
|
(fromIntegral $ noteTotal - 5000)
|
|
""
|
|
True
|
|
let feeResponse =
|
|
createTransaction
|
|
Nothing
|
|
Nothing
|
|
tSpends
|
|
[]
|
|
[]
|
|
[dummy]
|
|
znet
|
|
bh
|
|
False
|
|
case feeResponse of
|
|
Left e1 -> return $ Left Fee
|
|
Right fee -> do
|
|
let feeAmt =
|
|
fromIntegral
|
|
(runGet getInt64le $ LBS.fromStrict $ toBytes fee)
|
|
let snote =
|
|
OutgoingNote
|
|
4
|
|
(getBytes $
|
|
getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc)
|
|
(getBytes oRcvr)
|
|
(fromIntegral $ noteTotal - feeAmt)
|
|
""
|
|
True
|
|
let tx =
|
|
createTransaction
|
|
Nothing
|
|
Nothing
|
|
tSpends
|
|
[]
|
|
[]
|
|
[snote]
|
|
znet
|
|
(bh + 3)
|
|
True
|
|
logDebugN $ T.pack $ show tx
|
|
return tx
|
|
where
|
|
getTotalAmount ::
|
|
( [Entity WalletTrNote]
|
|
, [Entity WalletSapNote]
|
|
, [Entity WalletOrchNote])
|
|
-> Integer
|
|
getTotalAmount (t, s, o) =
|
|
sum (map (fromIntegral . walletTrNoteValue . entityVal) t) +
|
|
sum (map (fromIntegral . walletSapNoteValue . entityVal) s) +
|
|
sum (map (fromIntegral . walletOrchNoteValue . entityVal) o)
|
|
prepTSpends ::
|
|
TransparentSpendingKey
|
|
-> [Entity WalletTrNote]
|
|
-> IO [TransparentTxSpend]
|
|
prepTSpends sk notes = do
|
|
forM notes $ \n -> do
|
|
tAddRead <- getAddressById pool $ walletTrNoteAddress $ entityVal n
|
|
case tAddRead of
|
|
Nothing -> throwIO $ userError "Couldn't read t-address"
|
|
Just tAdd -> do
|
|
(XPrvKey _ _ _ _ (SecKey xp_key)) <-
|
|
genTransparentSecretKey
|
|
(walletAddressIndex $ entityVal tAdd)
|
|
(getScope $ walletAddressScope $ entityVal tAdd)
|
|
sk
|
|
mReverseTxId <- getWalletTxId pool $ walletTrNoteTx $ entityVal n
|
|
case mReverseTxId of
|
|
Nothing -> throwIO $ userError "failed to get tx ID"
|
|
Just (ESQ.Value reverseTxId) -> do
|
|
let flipTxId = BS.reverse $ toBytes $ getHex reverseTxId
|
|
return $
|
|
TransparentTxSpend
|
|
xp_key
|
|
(RawOutPoint
|
|
flipTxId
|
|
(fromIntegral $ walletTrNotePosition $ entityVal n))
|
|
(RawTxOut
|
|
(fromIntegral $ walletTrNoteValue $ entityVal n)
|
|
(walletTrNoteScript $ entityVal n))
|
|
|
|
-- | Prepare a transaction for sending
|
|
prepareTxV2 ::
|
|
ConnectionPool
|
|
-> T.Text
|
|
-> Int
|
|
-> ZcashNet
|
|
-> ZcashAccountId
|
|
-> Int
|
|
-> [ProposedNote]
|
|
-> PrivacyPolicy
|
|
-> LoggingT IO (Either TxError HexString)
|
|
prepareTxV2 pool zebraHost zebraPort zn za bh pnotes policy = do
|
|
accRead <- liftIO $ getAccountById pool za
|
|
let recipients = map extractReceiver pnotes
|
|
logDebugN $ T.pack $ show recipients
|
|
logDebugN $ T.pack $ "Target block: " ++ show bh
|
|
{-
|
|
-trees <- liftIO $ getCommitmentTrees zebraHost zebraPort bh
|
|
-let sT = SaplingCommitmentTree $ ztiSapling trees
|
|
-let oT = OrchardCommitmentTree $ ztiOrchard trees
|
|
-}
|
|
case accRead of
|
|
Nothing -> do
|
|
logErrorN "Can't find Account"
|
|
return $ Left ZHError
|
|
Just acc -> do
|
|
logDebugN $ T.pack $ show acc
|
|
let amt = foldl' (\x y -> x + pn_amt y) 0 pnotes
|
|
let zats' = toBoundedInteger $ amt * scientific 1 8
|
|
case zats' of
|
|
Nothing -> do
|
|
logErrorN "Failed to parse amount into zats"
|
|
return $ Left ZHError
|
|
Just zats -> do
|
|
logDebugN $ "amt: " <> T.pack (show amt)
|
|
logDebugN $ "zats: " <> T.pack (show zats)
|
|
{-firstPass <- liftIO $ selectUnspentNotes pool za zats-}
|
|
--let fee = calculateTxFee firstPass $ fst recipient
|
|
--logDebugN $ T.pack $ "calculated fee " ++ show fee
|
|
notePlan <-
|
|
liftIO $
|
|
selectUnspentNotesV2
|
|
pool
|
|
za
|
|
(zats + 10000)
|
|
(map (\(x, _, _, _) -> x) recipients)
|
|
policy
|
|
case notePlan of
|
|
Right (tList, sList, oList) -> do
|
|
logDebugN "selected notes"
|
|
logDebugN $ T.pack $ show tList
|
|
logDebugN $ T.pack $ show sList
|
|
logDebugN $ T.pack $ show oList
|
|
let noteTotal = getTotalAmount (tList, sList, oList)
|
|
logDebugN $ "noteTotal: " <> T.pack (show noteTotal)
|
|
tSpends <-
|
|
liftIO $
|
|
prepTSpends
|
|
(getTranSK $ zcashAccountTPrivateKey $ entityVal acc)
|
|
tList
|
|
--print tSpends
|
|
sSpends <-
|
|
liftIO $
|
|
prepSSpends
|
|
(getSapSK $ zcashAccountSapSpendKey $ entityVal acc)
|
|
sList
|
|
--print sSpends
|
|
oSpends <-
|
|
liftIO $
|
|
prepOSpends
|
|
(getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc)
|
|
oList
|
|
--print oSpends
|
|
dummy' <-
|
|
liftIO $
|
|
makeOutgoing
|
|
acc
|
|
recipients
|
|
(noteTotal - 5000 - fromIntegral zats)
|
|
policy
|
|
case dummy' of
|
|
Left e -> return $ Left e
|
|
Right dummy -> do
|
|
logDebugN "Calculating fee"
|
|
let feeResponse =
|
|
createTransaction
|
|
Nothing
|
|
Nothing
|
|
tSpends
|
|
sSpends
|
|
oSpends
|
|
dummy
|
|
zn
|
|
bh
|
|
False
|
|
case feeResponse of
|
|
Left e1 -> return $ Left Fee
|
|
Right fee -> do
|
|
let feeAmt =
|
|
fromIntegral
|
|
(runGet getInt64le $ LBS.fromStrict $ toBytes fee)
|
|
finalNotePlan <-
|
|
liftIO $
|
|
selectUnspentNotesV2
|
|
pool
|
|
za
|
|
(fromIntegral zats + feeAmt)
|
|
(map (\(x, _, _, _) -> x) recipients)
|
|
policy
|
|
case finalNotePlan of
|
|
Right (tList1, sList1, oList1) -> do
|
|
logDebugN $
|
|
T.pack $ "selected notes with fee" ++ show feeAmt
|
|
logDebugN $ T.pack $ show tList1
|
|
logDebugN $ T.pack $ show sList1
|
|
logDebugN $ T.pack $ show oList1
|
|
tSpends1 <-
|
|
liftIO $
|
|
prepTSpends
|
|
(getTranSK $
|
|
zcashAccountTPrivateKey $ entityVal acc)
|
|
tList1
|
|
sSpends1 <-
|
|
liftIO $
|
|
prepSSpends
|
|
(getSapSK $
|
|
zcashAccountSapSpendKey $ entityVal acc)
|
|
sList1
|
|
oSpends1 <-
|
|
liftIO $
|
|
prepOSpends
|
|
(getOrchSK $
|
|
zcashAccountOrchSpendKey $ entityVal acc)
|
|
oList1
|
|
let noteTotal1 =
|
|
getTotalAmount (tList1, sList1, oList1)
|
|
outgoing' <-
|
|
liftIO $
|
|
makeOutgoing
|
|
acc
|
|
recipients
|
|
(noteTotal1 - feeAmt - fromIntegral zats)
|
|
policy
|
|
logDebugN $ T.pack $ show outgoing'
|
|
case outgoing' of
|
|
Left e -> return $ Left e
|
|
Right outgoing -> do
|
|
let tx =
|
|
createTransaction
|
|
Nothing
|
|
Nothing
|
|
tSpends1
|
|
sSpends1
|
|
oSpends1
|
|
outgoing
|
|
zn
|
|
bh
|
|
True
|
|
logDebugN $ T.pack $ show tx
|
|
return tx
|
|
Left e -> return $ Left e
|
|
Left e -> do
|
|
logErrorN $ T.pack $ show e
|
|
return $ Left e
|
|
where
|
|
extractReceiver :: ProposedNote -> (Int, BS.ByteString, Int64, T.Text)
|
|
extractReceiver (ProposedNote (ValidAddressAPI va) amt m) =
|
|
let zats' = toBoundedInteger $ amt * scientific 1 8
|
|
in case zats' of
|
|
Nothing -> (0, "", 0, "")
|
|
Just zats ->
|
|
case va of
|
|
Unified ua ->
|
|
case o_rec ua of
|
|
Nothing ->
|
|
case s_rec ua of
|
|
Nothing ->
|
|
case t_rec ua of
|
|
Nothing -> (0, "", 0, "")
|
|
Just r3 ->
|
|
case tr_type r3 of
|
|
P2PKH ->
|
|
( 1
|
|
, toBytes $ tr_bytes r3
|
|
, zats
|
|
, fromMaybe "" m)
|
|
P2SH ->
|
|
( 2
|
|
, toBytes $ tr_bytes r3
|
|
, zats
|
|
, fromMaybe "" m)
|
|
Just r2 -> (3, getBytes r2, zats, fromMaybe "" m)
|
|
Just r1 -> (4, getBytes r1, zats, fromMaybe "" m)
|
|
Sapling sa ->
|
|
(3, getBytes $ sa_receiver sa, zats, fromMaybe "" m)
|
|
Transparent ta ->
|
|
case tr_type (ta_receiver ta) of
|
|
P2PKH ->
|
|
( 1
|
|
, toBytes $ tr_bytes (ta_receiver ta)
|
|
, zats
|
|
, fromMaybe "" m)
|
|
P2SH ->
|
|
( 2
|
|
, toBytes $ tr_bytes (ta_receiver ta)
|
|
, zats
|
|
, fromMaybe "" m)
|
|
Exchange ea ->
|
|
case tr_type (ex_address ea) of
|
|
P2PKH ->
|
|
( 5
|
|
, toBytes $ tr_bytes (ex_address ea)
|
|
, zats
|
|
, fromMaybe "" m)
|
|
P2SH ->
|
|
( 6
|
|
, toBytes $ tr_bytes (ex_address ea)
|
|
, zats
|
|
, fromMaybe "" m)
|
|
prepareOutgoingNote ::
|
|
ZcashAccount -> (Int, BS.ByteString, Int64, T.Text) -> OutgoingNote
|
|
prepareOutgoingNote zac (k, r, a, m) =
|
|
OutgoingNote
|
|
(if k == 5
|
|
then 1
|
|
else if k == 6
|
|
then 2
|
|
else fromIntegral k)
|
|
(case k of
|
|
4 -> getBytes $ getOrchSK $ zcashAccountOrchSpendKey zac
|
|
3 -> getBytes $ getSapSK $ zcashAccountSapSpendKey zac
|
|
_anyOther -> BS.empty)
|
|
r
|
|
(fromIntegral a)
|
|
(E.encodeUtf8 m)
|
|
False
|
|
makeOutgoing ::
|
|
Entity ZcashAccount
|
|
-> [(Int, BS.ByteString, Int64, T.Text)]
|
|
-> Int64
|
|
-> PrivacyPolicy
|
|
-> IO (Either TxError [OutgoingNote])
|
|
makeOutgoing acc recvs chg pol = do
|
|
let k = map (\(x, _, _, _) -> x) recvs
|
|
let j = map (\(_, _, x, _) -> x) recvs
|
|
chgAddr <- runNoLoggingT $ getInternalAddresses pool $ entityKey acc
|
|
let internalUA = getUA $ walletAddressUAddress $ entityVal $ head chgAddr
|
|
case pol of
|
|
Full ->
|
|
if elem 1 k || elem 2 k || elem 5 k || elem 6 k
|
|
then return $
|
|
Left $
|
|
PrivacyPolicyError
|
|
"Receiver not compatible with privacy policy"
|
|
else if elem 3 k && elem 4 k
|
|
then return $
|
|
Left $
|
|
PrivacyPolicyError
|
|
"Multiple shielded pools not allowed for Full privacy"
|
|
else if 3 `elem` k
|
|
then do
|
|
let chgRcvr =
|
|
fromJust $
|
|
s_rec =<<
|
|
isValidUnifiedAddress
|
|
(E.encodeUtf8 internalUA)
|
|
let cnote =
|
|
OutgoingNote
|
|
3
|
|
(getBytes $
|
|
getSapSK $
|
|
zcashAccountSapSpendKey $ entityVal acc)
|
|
(getBytes chgRcvr)
|
|
(fromIntegral chg)
|
|
""
|
|
True
|
|
let onotes =
|
|
map
|
|
(prepareOutgoingNote (entityVal acc))
|
|
recvs
|
|
return $ Right $ cnote : onotes
|
|
else if 4 `elem` k
|
|
then do
|
|
let chgRcvr =
|
|
fromJust $
|
|
o_rec =<<
|
|
isValidUnifiedAddress
|
|
(E.encodeUtf8 internalUA)
|
|
let cnote =
|
|
OutgoingNote
|
|
4
|
|
(getBytes $
|
|
getOrchSK $
|
|
zcashAccountOrchSpendKey $
|
|
entityVal acc)
|
|
(getBytes chgRcvr)
|
|
(fromIntegral chg)
|
|
""
|
|
True
|
|
let onotes =
|
|
map
|
|
(prepareOutgoingNote (entityVal acc))
|
|
recvs
|
|
return $ Right $ cnote : onotes
|
|
else return $ Left ZHError
|
|
Medium ->
|
|
if elem 1 k || elem 2 k || elem 5 k || elem 6 k
|
|
then return $
|
|
Left $
|
|
PrivacyPolicyError
|
|
"Receiver not compatible with privacy policy"
|
|
else do
|
|
let chgRcvr =
|
|
fromJust $
|
|
o_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA)
|
|
let cnote =
|
|
OutgoingNote
|
|
4
|
|
(getBytes $
|
|
getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc)
|
|
(getBytes chgRcvr)
|
|
(fromIntegral chg)
|
|
""
|
|
True
|
|
let onotes = map (prepareOutgoingNote (entityVal acc)) recvs
|
|
return $ Right $ cnote : onotes
|
|
Low ->
|
|
if elem 5 k || elem 6 k
|
|
then return $
|
|
Left $
|
|
PrivacyPolicyError
|
|
"Receiver not compatible with privacy policy"
|
|
else do
|
|
let chgRcvr =
|
|
fromJust $
|
|
o_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA)
|
|
let cnote =
|
|
OutgoingNote
|
|
4
|
|
(getBytes $
|
|
getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc)
|
|
(getBytes chgRcvr)
|
|
(fromIntegral chg)
|
|
""
|
|
True
|
|
let onotes = map (prepareOutgoingNote (entityVal acc)) recvs
|
|
return $ Right $ cnote : onotes
|
|
None ->
|
|
if elem 3 k || elem 4 k
|
|
then return $
|
|
Left $
|
|
PrivacyPolicyError
|
|
"Receiver not compatible with privacy policy"
|
|
else do
|
|
let chgRcvr =
|
|
fromJust $
|
|
t_rec =<< isValidUnifiedAddress (E.encodeUtf8 internalUA)
|
|
let cnote =
|
|
OutgoingNote
|
|
1
|
|
BS.empty
|
|
(toBytes $ tr_bytes chgRcvr)
|
|
(fromIntegral chg)
|
|
""
|
|
True
|
|
let onotes = map (prepareOutgoingNote (entityVal acc)) recvs
|
|
return $ Right $ cnote : onotes
|
|
getTotalAmount ::
|
|
( [Entity WalletTrNote]
|
|
, [Entity WalletSapNote]
|
|
, [Entity WalletOrchNote])
|
|
-> Int64
|
|
getTotalAmount (t, s, o) =
|
|
sum (map (fromIntegral . walletTrNoteValue . entityVal) t) +
|
|
sum (map (fromIntegral . walletSapNoteValue . entityVal) s) +
|
|
sum (map (fromIntegral . walletOrchNoteValue . entityVal) o)
|
|
prepTSpends ::
|
|
TransparentSpendingKey
|
|
-> [Entity WalletTrNote]
|
|
-> IO [TransparentTxSpend]
|
|
prepTSpends sk notes = do
|
|
forM notes $ \n -> do
|
|
tAddRead <- getAddressById pool $ walletTrNoteAddress $ entityVal n
|
|
case tAddRead of
|
|
Nothing -> throwIO $ userError "Couldn't read t-address"
|
|
Just tAdd -> do
|
|
(XPrvKey _ _ _ _ (SecKey xp_key)) <-
|
|
genTransparentSecretKey
|
|
(walletAddressIndex $ entityVal tAdd)
|
|
(getScope $ walletAddressScope $ entityVal tAdd)
|
|
sk
|
|
mReverseTxId <- getWalletTxId pool $ walletTrNoteTx $ entityVal n
|
|
case mReverseTxId of
|
|
Nothing -> throwIO $ userError "failed to get tx ID"
|
|
Just (ESQ.Value reverseTxId) -> do
|
|
let flipTxId = BS.reverse $ toBytes $ getHex reverseTxId
|
|
return $
|
|
TransparentTxSpend
|
|
xp_key
|
|
(RawOutPoint
|
|
flipTxId
|
|
(fromIntegral $ walletTrNotePosition $ entityVal n))
|
|
(RawTxOut
|
|
(fromIntegral $ walletTrNoteValue $ entityVal n)
|
|
(walletTrNoteScript $ entityVal n))
|
|
prepSSpends ::
|
|
SaplingSpendingKey -> [Entity WalletSapNote] -> IO [SaplingTxSpend]
|
|
prepSSpends sk notes = do
|
|
forM notes $ \n -> do
|
|
return $
|
|
SaplingTxSpend
|
|
(getBytes sk)
|
|
(DecodedNote
|
|
(fromIntegral $ walletSapNoteValue $ entityVal n)
|
|
(walletSapNoteRecipient $ entityVal n)
|
|
(E.encodeUtf8 $ walletSapNoteMemo $ entityVal n)
|
|
(getHex $ walletSapNoteNullifier $ entityVal n)
|
|
""
|
|
(getRseed $ walletSapNoteRseed $ entityVal n))
|
|
(toBytes $ getHex $ walletSapNoteWitness $ entityVal n)
|
|
prepOSpends ::
|
|
OrchardSpendingKey -> [Entity WalletOrchNote] -> IO [OrchardTxSpend]
|
|
prepOSpends sk notes = do
|
|
forM notes $ \n -> do
|
|
return $
|
|
OrchardTxSpend
|
|
(getBytes sk)
|
|
(DecodedNote
|
|
(fromIntegral $ walletOrchNoteValue $ entityVal n)
|
|
(walletOrchNoteRecipient $ entityVal n)
|
|
(E.encodeUtf8 $ walletOrchNoteMemo $ entityVal n)
|
|
(getHex $ walletOrchNoteNullifier $ entityVal n)
|
|
(walletOrchNoteRho $ entityVal n)
|
|
(getRseed $ walletOrchNoteRseed $ entityVal n))
|
|
(toBytes $ getHex $ walletOrchNoteWitness $ entityVal n)
|
|
sapAnchor :: [Entity WalletSapNote] -> Maybe SaplingWitness
|
|
sapAnchor notes =
|
|
if not (null notes)
|
|
then Just $
|
|
SaplingWitness $
|
|
getHex $ walletSapNoteWitness $ entityVal $ head notes
|
|
else Nothing
|
|
orchAnchor :: [Entity WalletOrchNote] -> Maybe OrchardWitness
|
|
orchAnchor notes =
|
|
if not (null notes)
|
|
then Just $
|
|
OrchardWitness $
|
|
getHex $ walletOrchNoteWitness $ entityVal $ head notes
|
|
else Nothing
|
|
|
|
-- | Sync the wallet with the data store
|
|
syncWallet ::
|
|
Config -- ^ configuration parameters
|
|
-> Entity ZcashWallet
|
|
-> LoggingT IO ()
|
|
syncWallet config w = do
|
|
startTime <- liftIO getCurrentTime
|
|
logDebugN $ T.pack $ show startTime
|
|
let walletDb = c_dbPath config
|
|
let znet = zcashWalletNetwork $ entityVal w
|
|
pool <- liftIO $ runNoLoggingT $ initPool walletDb
|
|
accs <- liftIO $ runNoLoggingT $ getAccounts pool $ entityKey w
|
|
addrs <-
|
|
concat <$>
|
|
mapM (liftIO . runNoLoggingT . getAddresses pool . entityKey) accs
|
|
logDebugN $ "addrs: " <> T.pack (show addrs)
|
|
intAddrs <-
|
|
concat <$>
|
|
mapM (liftIO . runNoLoggingT . getInternalAddresses pool . entityKey) accs
|
|
chainTip <- liftIO $ getMaxBlock pool znet
|
|
logDebugN $ "chain tip: " <> T.pack (show chainTip)
|
|
lastBlock <- liftIO $ getLastSyncBlock pool $ entityKey w
|
|
logDebugN $ "last block: " <> T.pack (show lastBlock)
|
|
let startBlock =
|
|
if lastBlock > 0
|
|
then lastBlock
|
|
else 1 + zcashWalletBirthdayHeight (entityVal w)
|
|
logDebugN $ "start block: " <> T.pack (show startBlock)
|
|
mapM_ (liftIO . findTransparentNotes pool startBlock znet) addrs
|
|
mapM_ (liftIO . findTransparentNotes pool startBlock znet) intAddrs
|
|
logDebugN "processed transparent notes"
|
|
mapM_ (liftIO . findTransparentSpends pool . entityKey) accs
|
|
logDebugN "processed transparent spends"
|
|
liftIO $
|
|
runNoLoggingT $
|
|
mapM_
|
|
(findSaplingOutputs config startBlock (zcashWalletNetwork $ entityVal w))
|
|
accs
|
|
logDebugN "processed sapling outputs"
|
|
liftIO $
|
|
mapM_
|
|
(findOrchardActions config startBlock (zcashWalletNetwork $ entityVal w))
|
|
accs
|
|
logDebugN "processed orchard actions"
|
|
_ <- liftIO $ updateSaplingWitnesses pool
|
|
logDebugN "updated sapling witnesses"
|
|
_ <- liftIO $ updateOrchardWitnesses pool
|
|
logDebugN "updated orchard witnesses"
|
|
_ <- liftIO $ updateWalletSync pool chainTip (entityKey w)
|
|
logDebugN "updated wallet lastSync"
|
|
mapM_ (liftIO . runNoLoggingT . getWalletTransactions pool) addrs
|