Vergara_Tech/zgo-backend
Vergara_Tech
/
zgo-backend
2
1
Fork 0
Code Issues Pull Requests Packages Projects Releases 4 Wiki Activity

Alpha version of native Tx scanning

This commit is contained in:
Rene Vergara 2023-09-28 10:47:05 -05:00
parent c5724d6d4a
commit a134947df6
Signed by: pitmutt
GPG Key ID: 65122AD495A7F5B2
2 changed files with 162 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
CHANGELOG.md
View File

@ -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]

210
src/ZGoBackend.hs
View File

@ -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")