{-# LANGUAGE OverloadedStrings #-} -- | Core wallet functionality for Zenith module Zenith.Core where import Control.Exception (throwIO, try) import Control.Monad (forM, when) import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger ( LoggingT , MonadLoggerIO , logInfoN , logWarnN , runFileLoggingT , runStdoutLoggingT ) import Crypto.Secp256k1 (SecKey(..)) import Data.Aeson import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.Digest.Pure.MD5 import Data.HexString (HexString, hexString, toBytes) import Data.List import Data.Maybe (fromJust) import Data.Pool (Pool) 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 (floorFloatInteger) import Haskoin.Crypto.Keys (XPrvKey(..)) import Network.HTTP.Client import ZcashHaskell.Keys import ZcashHaskell.Orchard ( decryptOrchardActionSK , encodeUnifiedAddress , genOrchardReceiver , genOrchardSpendingKey , getOrchardNotePosition , getOrchardWitness , isValidUnifiedAddress , updateOrchardCommitmentTree , updateOrchardWitness ) import ZcashHaskell.Sapling ( decodeSaplingOutputEsk , genSaplingInternalAddress , genSaplingPaymentAddress , genSaplingSpendingKey , 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(..) , RseedDB(..) , 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 wId <- saveWalletTransaction (c_dbPath config) (entityKey za) zt saveWalletSapNote (c_dbPath config) wId nP (fromJust noteWitness) True (entityKey za) (entityKey o) dn1 decryptNotes uT n txs Just dn0 -> do wId <- saveWalletTransaction (c_dbPath config) (entityKey za) zt saveWalletSapNote (c_dbPath config) wId nP (fromJust noteWitness) False (entityKey za) (entityKey o) 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 wId <- saveWalletTransaction (c_dbPath config) (entityKey za) zt saveWalletOrchNote (c_dbPath config) wId nP (fromJust noteWitness) True (entityKey za) (entityKey o) dn1 decryptNotes uT n txs Just dn -> do wId <- saveWalletTransaction (c_dbPath config) (entityKey za) zt saveWalletOrchNote (c_dbPath config) wId nP (fromJust noteWitness) False (entityKey za) (entityKey o) 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) updateSaplingWitnesses :: T.Text -> LoggingT IO () updateSaplingWitnesses dbPath = do sapNotes <- liftIO $ getUnspentSapNotes dbPath pool <- createSqlitePool dbPath 5 maxId <- liftIO $ getMaxSaplingNote pool mapM_ (updateOneNote pool maxId) sapNotes where updateOneNote :: Pool SqlBackend -> ShieldOutputId -> Entity WalletSapNote -> LoggingT IO () updateOneNote pool maxId n = do let noteSync = walletSapNoteWitPos $ entityVal n if noteSync < maxId then do cmus <- liftIO $ getSaplingCmus pool $ walletSapNoteWitPos $ entityVal n 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 else logInfoN "Witness up to date" updateOrchardWitnesses :: T.Text -> LoggingT IO () updateOrchardWitnesses dbPath = do orchNotes <- liftIO $ getUnspentOrchNotes dbPath pool <- createSqlitePool dbPath 5 maxId <- liftIO $ getMaxOrchardNote pool mapM_ (updateOneNote pool maxId) orchNotes where updateOneNote :: Pool SqlBackend -> OrchActionId -> Entity WalletOrchNote -> LoggingT IO () updateOneNote pool maxId n = do let noteSync = walletOrchNoteWitPos $ entityVal n if noteSync < maxId then do cmxs <- liftIO $ getOrchardCmxs pool noteSync 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 else logInfoN "Witness up to date" -- | 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 then 1 else 0 sout = if i == 2 then 1 else 0 oout = if i == 3 then 2 else 1 -- | Prepare a transaction for sending prepareTx :: T.Text -> T.Text -> Int -> ZcashNet -> ZcashAccountId -> Int -> Float -> UnifiedAddress -> T.Text -> IO (Either TxError HexString) prepareTx dbPath zebraHost zebraPort zn za bh amt ua memo = do accRead <- getAccountById dbPath 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) print recipient trees <- getCommitmentTrees zebraHost zebraPort bh let sT = SaplingCommitmentTree $ ztiSapling trees let oT = OrchardCommitmentTree $ ztiOrchard trees case accRead of Nothing -> throwIO $ userError "Can't find Account" Just acc -> do print acc spParams <- BS.readFile "sapling-spend.params" outParams <- BS.readFile "sapling-output.params" if show (md5 $ LBS.fromStrict spParams) /= "0f44c12ef115ae019decf18ade583b20" then throwIO $ userError "Can't validate sapling parameters" else print "Valid Sapling spend params" if show (md5 $ LBS.fromStrict outParams) /= "924daf81b87a81bbbb9c7d18562046c8" then throwIO $ userError "Can't validate sapling parameters" else print "Valid Sapling output params" print $ BS.length spParams print $ BS.length outParams print "Read Sapling params" let zats = fromIntegral $ floorFloatInteger $ amt * (10 ^ 8) firstPass <- selectUnspentNotes dbPath za zats let fee = calculateTxFee firstPass 3 print "calculated fee" print fee (tList, sList, oList) <- selectUnspentNotes dbPath za (zats + fee) print "selected notes" print tList print sList print oList let noteTotal = getTotalAmount (tList, sList, oList) print noteTotal tSpends <- prepTSpends (getTranSK $ zcashAccountTPrivateKey $ entityVal acc) tList print tSpends sSpends <- prepSSpends (getSapSK $ zcashAccountSapSpendKey $ entityVal acc) sList print sSpends oSpends <- prepOSpends (getOrchSK $ zcashAccountOrchSpendKey $ entityVal acc) oList print oSpends outgoing <- makeOutgoing acc recipient zats (noteTotal - fee - zats) print outgoing let tx = createTransaction (Just sT) (Just oT) tSpends sSpends oSpends outgoing (SaplingSpendParams spParams) (SaplingOutputParams outParams) zn (bh + 3) return tx where makeOutgoing :: Entity ZcashAccount -> (Int, BS.ByteString) -> Integer -> Integer -> IO [OutgoingNote] makeOutgoing acc (k, recvr) zats chg = do chgAddr <- getInternalAddresses dbPath $ 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 dbPath $ walletTrNoteAddress $ entityVal n print 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 dbPath $ 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 (walletTrNoteValue $ entityVal n) (walletTrNoteScript $ entityVal n)) prepSSpends :: SaplingSpendingKey -> [Entity WalletSapNote] -> IO [SaplingTxSpend] prepSSpends sk notes = do forM notes $ \n -> do print n 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 print n 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 let walletDb = c_dbPath config accs <- liftIO $ getAccounts walletDb $ entityKey w addrs <- liftIO $ concat <$> mapM (getAddresses walletDb . entityKey) accs intAddrs <- liftIO $ concat <$> mapM (getInternalAddresses walletDb . entityKey) accs chainTip <- liftIO $ getMaxBlock walletDb let lastBlock = zcashWalletLastSync $ entityVal w let startBlock = if lastBlock > 0 then lastBlock else zcashWalletBirthdayHeight $ entityVal w mapM_ (liftIO . findTransparentNotes walletDb startBlock) addrs mapM_ (liftIO . findTransparentNotes walletDb startBlock) intAddrs mapM_ (liftIO . findTransparentSpends walletDb . entityKey) accs sapNotes <- liftIO $ mapM (findSaplingOutputs config startBlock (zcashWalletNetwork $ entityVal w)) accs orchNotes <- liftIO $ mapM (findOrchardActions config startBlock (zcashWalletNetwork $ entityVal w)) accs _ <- updateSaplingWitnesses walletDb _ <- updateOrchardWitnesses walletDb _ <- liftIO $ updateWalletSync walletDb chainTip (entityKey w) _ <- liftIO $ mapM_ (getWalletTransactions walletDb) addrs logInfoN "Synced wallet" testSync :: Config -> IO () testSync config = do let dbPath = c_dbPath config _ <- initDb dbPath w <- getWallets dbPath TestNet r <- runFileLoggingT "zenith.log" $ mapM (syncWallet config) w liftIO $ print r testSend :: IO () testSend = do let uaRead = isValidUnifiedAddress "utest1dl54utt6prjj5e0dnlknwumnxq9hycdjpkfr0sy6e6h522remqee8axe9zax0wsjrwpj76v555pdhvj9rnargpfyycs0vpkapq98xcdhem99gc4wchzn0ggepq3y6nz3a9sscwgqxgsh9vzhcad402y3x9szfregck5gslkya3c79d86xx0l33tpk8gnn7ew9vw37w43zh22u8dgdax" case uaRead of Nothing -> print "wrong address" Just ua -> do startTime <- getCurrentTime print startTime tx <- prepareTx "zenith.db" "127.0.0.1" 18232 TestNet (toSqlKey 1) 2820897 0.04 ua "sent with Zenith, test" print tx endTime <- getCurrentTime print endTime clearSync :: Config -> IO () clearSync config = do let dbPath = c_dbPath config _ <- initDb dbPath _ <- clearWalletTransactions dbPath w <- getWallets dbPath TestNet liftIO $ mapM_ (updateWalletSync dbPath 0 . entityKey) w w' <- liftIO $ getWallets dbPath TestNet r <- runFileLoggingT "zenith.log" $ mapM (syncWallet config) w' liftIO $ print r