{-# 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, [], []) let fee = calculateTxFee (trNotes, [], []) 4 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 snote = OutgoingNote 4 (getBytes $ getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc) (getBytes oRcvr) (fromIntegral $ noteTotal - fee) "" 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