From a134947df6af5b0729be20540addffdc91fd36c6 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 28 Sep 2023 10:47:05 -0500 Subject: [PATCH] Alpha version of native Tx scanning --- CHANGELOG.md | 15 +++- src/ZGoBackend.hs | 210 ++++++++++++++++++++++++++++++++-------------- 2 files changed, 162 insertions(+), 63 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 9f26074..2712b8b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,9 +6,22 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] -## Changed +### Added + +- Parser for Unified Addresses that validates the address +- Tests for UA parsing from wallets +- Function to scan new transactions using known viewing keys +- Function to identify the owners and VKs needed for tx scans + +### Changed - MongoDB driver updated to support MongoDB 6. +- Full validation of Sapling addresses to parser. + +### Removed + +- `makeZcashCall` function moved to the generic `zcash-haskell` library. +- `RpcResponse`, `RpcCall` types moved to the generic `zcash-haskell` library. ## [1.7.0] diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 85d1ac8..83539ed 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -25,7 +25,7 @@ import Data.Char import qualified Data.HashMap.Strict as HM import Data.HexString import Data.Maybe -import qualified Data.Scientific as Scientific +import qualified Data.Scientific as SC import Data.SecureMem import qualified Data.Text as T import qualified Data.Text.Encoding as E @@ -37,9 +37,8 @@ import Data.Time.Format import Data.Typeable import qualified Data.UUID as U import qualified Data.Vector as V -import Data.Vector.Internal.Check (doChecks) import Data.Word -import Database.MongoDB hiding (Order) +import Database.MongoDB hiding (Order, lookup) import Debug.Trace import GHC.Generics import Item @@ -66,47 +65,20 @@ import Web.Scotty import WooCommerce import Xero import ZGoTx +import ZcashHaskell.Orchard import ZcashHaskell.Sapling -import ZcashHaskell.Types (RawData(..)) -import ZcashHaskell.Utils (decodeBech32) +import ZcashHaskell.Types + ( BlockResponse(..) + , RawData(..) + , RawTxResponse(..) + , RpcCall(..) + , RpcError(..) + , RpcResponse(..) + , UnifiedFullViewingKey(..) + ) +import ZcashHaskell.Utils (decodeBech32, makeZcashCall) -- Models for API objects --- | A type to model Zcash RPC calls -data RpcCall = RpcCall - { jsonrpc :: T.Text - , callId :: T.Text - , method :: T.Text - , parameters :: [Data.Aeson.Value] - } deriving (Show, Generic) - -instance ToJSON RpcCall where - toJSON (RpcCall j c m p) = - object ["jsonrpc" .= j, "id" .= c, "method" .= m, "params" .= p] - --- | A type to model the response of the Zcash RPC -data RpcResponse r = MakeRpcResponse - { err :: Maybe RpcError - , respId :: T.Text - , result :: Maybe r - } deriving (Show, Generic, ToJSON) - -instance (FromJSON r) => FromJSON (RpcResponse r) where - parseJSON (Object obj) = - MakeRpcResponse <$> obj .: "error" <*> obj .: "id" <*> obj .: "result" - parseJSON _ = mzero - -data RpcError = RpcError - { ecode :: Double - , emessage :: T.Text - } deriving (Show, Generic, ToJSON) - -instance FromJSON RpcError where - parseJSON = - withObject "RpcError" $ \obj -> do - c <- obj .: "code" - m <- obj .: "message" - pure $ RpcError c m - data Payload r = Payload { payload :: r } deriving (Show, Generic, ToJSON) @@ -1221,7 +1193,7 @@ routes pipe config = do "z_importviewingkey" [ Data.Aeson.String (T.strip . T.pack $ q) , "no" - ] + ] -- TODO: Remove this call to the node let content = getResponseBody vkInfo :: RpcResponse Object if isNothing (err content) @@ -1233,7 +1205,7 @@ routes pipe config = do text $ L.pack . show $ err content status badRequest400 else status forbidden403 - else status badRequest400 + else status badRequest400 -- TODO: add Unified VK support --Get items associated with the given address get "/api/items" $ do session <- param "session" @@ -1467,25 +1439,24 @@ routes pipe config = do {-liftAndCatchIO $-} {-mapM (run . loadLangComponent) (langComp :: [LangComponent])-} {-status created201-} + {-(MonadIO m, FromJSON a)-} + {-=> BS.ByteString-} + {--> BS.ByteString-} + {--> T.Text-} + {--> [Data.Aeson.Value]-} + {--> m (Response a)-} + {-let payload =-} + {-RpcCall {jsonrpc = "1.0", callId = "test", method = m, parameters = p}-} + {-let myRequest =-} + {-setRequestBodyJSON payload $-} + {-setRequestPort 8232 $-} + {-setRequestBasicAuth username password $-} + {-setRequestMethod "POST" defaultRequest-} + {-httpJSON myRequest-} -- | Make a Zcash RPC call -makeZcashCall :: - (MonadIO m, FromJSON a) - => BS.ByteString - -> BS.ByteString - -> T.Text - -> [Data.Aeson.Value] - -> m (Response a) -makeZcashCall username password m p = do - let payload = - RpcCall {jsonrpc = "1.0", callId = "test", method = m, parameters = p} - let myRequest = - setRequestBodyJSON payload $ - setRequestPort 8232 $ - setRequestBasicAuth username password $ - setRequestMethod "POST" defaultRequest - httpJSON myRequest - +{-makeZcashCall ::-} +{-makeZcashCall username password m p = do-} -- |Timer for repeating actions setInterval :: Int -> IO () -> IO () setInterval secs func = do @@ -1527,7 +1498,7 @@ listTxs user pwd a confs = do user pwd "z_listreceivedbyaddress" - [Data.Aeson.String a, Data.Aeson.Number $ Scientific.scientific confs 0] :: IO + [Data.Aeson.String a, Data.Aeson.Number $ SC.scientific confs 0] :: IO (Either HttpException (Response (RpcResponse [ZcashTx]))) case res of Right txList -> do @@ -1725,7 +1696,7 @@ payOwner p d x = markOwnerPaid :: Pipe -> T.Text -> Payment -> IO () markOwnerPaid pipe db pmt = do user <- access pipe master db (findUser $ psession pmt) - print pmt + -- print pmt let parsedUser = parseUserBson =<< user let zaddy = maybe "" uaddress parsedUser owner <- access pipe master db $ findOwner zaddy @@ -1831,4 +1802,119 @@ generateToken = do rngState <- newCryptoRNGState runCryptoRNGT rngState $ randomString 24 "abcdef0123456789" +getBlockInfo :: + BS.ByteString -> BS.ByteString -> SC.Scientific -> IO (Maybe BlockResponse) +getBlockInfo nodeUser nodePwd bh = do + blockInfo <- makeZcashCall nodeUser nodePwd "getblock" [Number bh] + let content = getResponseBody blockInfo :: RpcResponse BlockResponse + if isNothing (err content) + then return $ result content + else do + print $ err content + return Nothing + +scanTxNative :: Pipe -> T.Text -> BS.ByteString -> BS.ByteString -> IO () +scanTxNative pipe db nodeUser nodePwd = do + keyOwnerList <- access pipe master db findWithKeys + unless (null keyOwnerList) $ do + let ownerList = cast' . Doc <$> keyOwnerList + let keyList = map (maybe "" oviewkey) ownerList + lastBlockData <- access pipe master db findBlock + latestBlock <- getBlockInfo nodeUser nodePwd (SC.scientific (-1) 0) + case latestBlock of + Nothing -> fail "No block data from node" + Just lB -> do + case cast' . Doc =<< lastBlockData of + Nothing -> do + blockList <- + mapM + (getBlockInfo nodeUser nodePwd . fromInteger) + [2220000 .. (bl_height lB)] + let filteredBlockList = filter filterBlock blockList + let txIdList = concatMap extractTxs filteredBlockList + txList <- mapM (getTxData nodeUser nodePwd) txIdList + let filteredTxList = map fromJust $ filter filterTx txList + mapM_ (checkTx filteredTxList) keyList + Just lastBlock -> do + let blockList' = [(bl_height lastBlock + 1) .. (bl_height lB)] + print blockList' + print keyList + where + filterBlock :: Maybe BlockResponse -> Bool + filterBlock b = maybe 0 bl_confirmations b >= 5 + filterTx :: Maybe RawTxResponse -> Bool + filterTx t = + not (null (maybe [] rt_shieldedOutputs t)) && + not (null (maybe [] rt_orchardActions t)) + extractTxs :: Maybe BlockResponse -> [T.Text] + extractTxs = maybe [] bl_txs + getTxData :: + BS.ByteString -> BS.ByteString -> T.Text -> IO (Maybe RawTxResponse) + getTxData nodeUser nodePwd txid = do + txInfo <- + makeZcashCall + nodeUser + nodePwd + "getrawtransaction" + [Data.Aeson.String txid] + let content = getResponseBody txInfo :: RpcResponse RawTxResponse + if isNothing (err content) + then return $ result content + else do + print $ err content + return Nothing + checkTx :: [RawTxResponse] -> T.Text -> IO () + checkTx txList k = do + if isValidSaplingViewingKey (E.encodeUtf8 k) + then do + let decodedTxList = + map + (decodeSaplingOutput (E.encodeUtf8 k)) + (concatMap + rt_shieldedOutputs + (filter (\x -> rt_shieldedOutputs x /= []) txList)) + print decodedTxList + else do + let vk = decodeUfvk $ E.encodeUtf8 k + case vk of + Nothing -> print "Not a valid key" + Just v -> do + let decodedSapList = + map + (decodeSaplingOutput (s_key v)) + (concatMap rt_shieldedOutputs txList) + print decodedSapList + let decodedOrchList = + map + (decryptOrchardAction v) + (concatMap rt_orchardActions txList) + print decodedOrchList + debug = flip trace + +instance Val BlockResponse where + cast' (Doc d) = do + c <- B.lookup "confirmations" d + h <- B.lookup "height" d + t <- B.lookup "time" d + txs <- B.lookup "tx" d + Just (BlockResponse c h t txs) + cast' _ = Nothing + val (BlockResponse c h t txs) = + Doc + [ "confirmations" =: c + , "height" =: h + , "time" =: t + , "tx" =: txs + , "network" =: ("mainnet" :: String) + ] + +upsertBlock :: BlockResponse -> Action IO () +upsertBlock b = do + let block = val b + case block of + Doc d -> upsert (select ["network" =: ("mainnet" :: String)] "blocks") d + _ -> return () + +findBlock :: Action IO (Maybe Document) +findBlock = findOne (select ["network" =: ("mainnet" :: String)] "blocks")