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

Add functionality to save viewing key 

Includes improvements on error handling for RPC calls to the Zcash node.
This commit is contained in:
Rene Vergara 2022-07-21 12:14:27 -05:00
parent 27a2fab424
commit 738b28a4ef
Signed by: pitmutt
GPG Key ID: 65122AD495A7F5B2
5 changed files with 250 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
CHANGELOG.md
View File

@ -14,6 +14,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
### Changed
- Added logic in `/api/owner` endpoint to validate viewing key before saving
- Updated tests for `/api/owner` to account for invalid viewing keys
- Added alphabetic sorting to list of items
- Refactored code to use new `Config` type
- Enhance `decodeHexText` to support Unicode

6
src/Order.hs
View File

@ -209,3 +209,9 @@ findAllOrders a = rest =<< find (select ["address" =: a] "orders")
deleteOrder :: String -> Action IO ()
deleteOrder i = deleteOne (select ["_id" =: (read i :: B.ObjectId)] "orders")
markOrderPaid :: String -> Action IO ()
markOrderPaid i =
modify
(select ["_id" =: (read i :: B.ObjectId)] "orders")
["$set" =: ["paid" =: True]]

203
src/ZGoBackend.hs
View File

@ -2,6 +2,7 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
module ZGoBackend where
@ -67,9 +68,9 @@ instance ToJSON RpcCall where
-- | A type to model the response of the Zcash RPC
data RpcResponse r =
MakeRpcResponse
{ err :: Maybe T.Text
{ err :: Maybe RpcError
, respId :: T.Text
, result :: r
, result :: Maybe r
}
deriving (Show, Generic, ToJSON)
@ -78,6 +79,20 @@ instance (FromJSON r) => FromJSON (RpcResponse r) where
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
@ -152,6 +167,109 @@ instance Arbitrary ZcashTx where
cm <- arbitrary
ZcashTx a aZ t bh bt c cm <$> arbitrary
-- | A type to model an address group
data AddressGroup =
AddressGroup
{ agsource :: AddressSource
, agtransparent :: [ZcashAddress]
, agsapling :: [ZcashAddress]
, agunified :: [ZcashAddress]
}
deriving (Show, Generic)
instance FromJSON AddressGroup where
parseJSON =
withObject "AddressGroup" $ \obj -> do
s <- obj .: "source"
t <- obj .:? "transparent"
sap <- obj .:? "sapling"
uni <- obj .:? "unified"
sL <- processSapling sap s
tL <- processTransparent t s
uL <- processUnified uni
return $ AddressGroup s tL (concat sL) (concat uL)
where
processTransparent c s1 =
case c of
Nothing -> return []
Just x -> do
x' <- x .: "addresses"
return $ map (ZcashAddress s1 [Transparent] Nothing) x'
processSapling k s2 =
case k of
Nothing -> return []
Just y -> mapM (processOneSapling s2) y
where processOneSapling sx =
withObject "Sapling" $ \oS -> do
oS' <- oS .: "addresses"
return $ map (ZcashAddress sx [Sapling] Nothing) oS'
processUnified u =
case u of
Nothing -> return []
Just z -> mapM processOneAccount z
where processOneAccount =
withObject "UAs" $ \uS -> do
acct <- uS .: "account"
uS' <- uS .: "addresses"
mapM (processUAs acct) uS'
where
processUAs a =
withObject "UAs" $ \v -> do
addr <- v .: "address"
p <- v .: "receiver_types"
return $ ZcashAddress MnemonicSeed p a addr
-- | Type for modelling the different address sources for Zcash 5.0.0
data AddressSource
= LegacyRandom
| Imported
| ImportedWatchOnly
| KeyPool
| LegacySeed
| MnemonicSeed
deriving (Read, Show, Eq, Generic, ToJSON)
instance FromJSON AddressSource where
parseJSON =
withText "AddressSource" $ \case
"legacy_random" -> return LegacyRandom
"imported" -> return Imported
"imported_watchonly" -> return ImportedWatchOnly
"keypool" -> return KeyPool
"legacy_hdseed" -> return LegacySeed
"mnemonic_seed" -> return MnemonicSeed
_ -> fail "Not a known address source"
data ZcashPool
= Transparent
| Sprout
| Sapling
| Orchard
deriving (Show, Eq, Generic, ToJSON)
instance FromJSON ZcashPool where
parseJSON =
withText "ZcashPool" $ \case
"p2pkh" -> return Transparent
"sprout" -> return Sprout
"sapling" -> return Sapling
"orchard" -> return Orchard
_ -> fail "Not a known Zcash pool"
data ZcashAddress =
ZcashAddress
{ source :: AddressSource
, pool :: [ZcashPool]
, account :: Maybe Integer
, addy :: T.Text
}
deriving (Eq)
instance Show ZcashAddress where
show (ZcashAddress s p i a) =
T.unpack (T.take 8 a) ++
"..." ++ T.unpack (T.takeEnd 8 a) ++ " Pools: " ++ show p
-- | Helper function to turn a hex-encoded memo strings to readable text
decodeHexText :: String -> T.Text
decodeHexText h = E.decodeUtf8With lenientDecode $ BS.pack $ hexRead h
@ -394,7 +512,13 @@ routes pipe config = do
--Get current blockheight from Zcash node
get "/api/blockheight" $ do
blockInfo <- makeZcashCall nodeUser nodePwd "getblock" ["-1"]
Web.Scotty.json (result (getResponseBody blockInfo :: RpcResponse Block))
let content = getResponseBody blockInfo :: RpcResponse Block
if isNothing (err content)
then do
status ok200
Web.Scotty.json $ fromMaybe (Block 0 0) (result content)
else do
status internalServerError500
--Get the ZGo node's shielded address
get "/api/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress])
--Get owner by address
@ -418,8 +542,30 @@ routes pipe config = do
post "/api/owner" $ do
o <- jsonData
let q = payload (o :: Payload Owner)
_ <- liftIO $ run (upsertOwner q)
status created201
known <- liftIO $ listAddresses nodeUser nodePwd
if not (opayconf q)
then do
_ <- liftIO $ run (upsertOwner q)
status created201
else do
if oaddress q `elem` map addy known
then do
_ <- liftIO $ run (upsertOwner q)
status created201
else do
vkInfo <-
makeZcashCall
nodeUser
nodePwd
"z_importviewingkey"
[Data.Aeson.String (oviewkey q), "no"]
let content = getResponseBody vkInfo :: RpcResponse Object
if isNothing (err content)
then do
_ <- liftIO $ run (upsertOwner q)
status created201
else do
status internalServerError500
--Get items associated with the given address
get "/api/items" $ do
addr <- param "address"
@ -574,25 +720,46 @@ scanZcash config pipe = do
(c_nodePwd config)
"z_listreceivedbyaddress"
[Data.Aeson.String (c_nodeAddress config)]
let txs =
filter (not . zchange) $
result (getResponseBody res :: RpcResponse [ZcashTx])
let r =
mkRegex
".*ZGO::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12})\\sReply-To:\\s(zs[a-z0-9]{76}).*"
let p =
mkRegex
".*ZGOp::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12}).*"
let k = map zToZGoTx (filter (isRelevant r) txs)
mapM_ (access pipe master (c_dbName config) . upsertZGoTx "txs") k
let j = map zToZGoTx (filter (isRelevant p) txs)
mapM_ (access pipe master (c_dbName config) . upsertPayment) j
let content = getResponseBody res :: RpcResponse [ZcashTx]
case err content of
Nothing -> do
let txs = filter (not . zchange) $ fromMaybe [] $ result content
let r =
mkRegex
".*ZGO::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12})\\sReply-To:\\s(zs[a-z0-9]{76}).*"
let p =
mkRegex
".*ZGOp::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12}).*"
let k = map zToZGoTx (filter (isRelevant r) txs)
mapM_ (access pipe master (c_dbName config) . upsertZGoTx "txs") k
let j = map zToZGoTx (filter (isRelevant p) txs)
mapM_ (access pipe master (c_dbName config) . upsertPayment) j
Just e -> do
putStrLn $ "Error scanning node transactions: " ++ T.unpack (emessage e)
return ()
where
isRelevant :: Text.Regex.Regex -> ZcashTx -> Bool
isRelevant re t
| zconfirmations t < 10 && (matchTest re . T.unpack . zmemo) t = True
| otherwise = False
-- | RPC methods
-- | List addresses with viewing keys loaded
listAddresses :: BS.ByteString -> BS.ByteString -> IO [ZcashAddress]
listAddresses user pwd = do
response <- makeZcashCall user pwd "listaddresses" []
let rpcResp = getResponseBody response
case rpcResp of
Nothing -> fail "Couldn't parse node response"
Just res -> do
let addys = fromMaybe [] $ result res :: [AddressGroup]
let addList = concatMap getAddresses addys
return $ filter (\a -> source a == ImportedWatchOnly) addList
-- | Helper function to extract addresses from AddressGroups
getAddresses :: AddressGroup -> [ZcashAddress]
getAddresses ag = agtransparent ag <> agsapling ag <> agunified ag
-- | Function to generate users from login txs
updateLogins :: Pipe -> Config -> IO ()
updateLogins pipe config = do

61
test/Spec.hs
View File

@ -2,6 +2,7 @@
module Spec where
import Config
import Control.Concurrent (forkIO, threadDelay)
import Control.Exception (bracket)
import Control.Monad.IO.Class
@ -38,12 +39,7 @@ import ZGoTx
main :: IO ()
main = do
putStrLn "Reading config..."
config <- load ["zgo.cfg"]
let dbName = "test"
nodeAddress <- require config "nodeAddress"
nodeUser <- require config "nodeUser"
nodePwd <- require config "nodePassword"
passkey <- secureMemFromByteString <$> require config "passkey"
loadedConfig <- loadZGoConfig "zgotest.cfg"
hspec $ do
describe "Helper functions" $ do
describe "decodeHexText" $ do
@ -80,7 +76,7 @@ main = do
it "should give a 7 digit" $ do
length (T.unpack (unsafePerformIO generatePin)) `shouldBe` 7
describe "API endpoints" $ do
beforeAll_ (startAPI dbName passkey nodeAddress nodeUser nodePwd) $ do
beforeAll_ (startAPI loadedConfig) $ do
describe "Price endpoint" $ do
it "returns a price for an existing currency" $ do
req <- testGet "/api/price" [("currency", Just "usd")]
@ -237,11 +233,38 @@ main = do
access p master "test" $
findOne (select ["_id" =: userId] "users")
isNothing q `shouldBe` True
describe "Orders" $ do
it "marked as paid" $ \p -> do
myTs <- liftIO getCurrentTime
let myOrder =
ZGoOrder
(Just (read "627ab3ea2b05a76be3000001"))
"Zaddy"
"35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd"
myTs
False
"usd"
102.0
0
0
[]
False
let ordTest = val myOrder
case ordTest of
Doc oT -> access p master "test" (insert_ "orders" oT)
_ <-
access p master "test" $ markOrderPaid "627ab3ea2b05a76be3000001"
o <-
access p master "test" $ findOrderById "627ab3ea2b05a76be3000001"
let o1 = (cast' . Doc) =<< o
case o1 of
Nothing -> True `shouldBe` False
Just o2 -> qpaid o2 `shouldBe` True
describe "Zcash transactions" $ do
it "logins are added to db" $ \p -> do
_ <-
access p master "test" (Database.MongoDB.delete (select [] "txs"))
_ <- scanZcash nodeAddress p "test" nodeUser nodePwd
_ <- scanZcash loadedConfig p
threadDelay 1000000
t <- access p master "test" $ findOne (select [] "txs")
let s = parseZGoTxBson =<< t
@ -254,7 +277,7 @@ main = do
master
"test"
(Database.MongoDB.delete (select [] "payments"))
_ <- scanZcash nodeAddress p "test" nodeUser nodePwd
_ <- scanZcash loadedConfig p
threadDelay 1000000
t <- access p master "test" $ findOne (select [] "payments")
let s = (cast' . Doc) =<< t
@ -345,7 +368,7 @@ main = do
"test"
(Database.MongoDB.delete (select [] "users"))
_ <- access p master "test" (insert_ "txs" (encodeZGoTxBson myTx))
_ <- updateLogins nodeUser nodePwd nodeAddress p "test"
_ <- updateLogins p loadedConfig
threadDelay 1000000
t <- access p master "test" $ findOne (select [] "users")
case t of
@ -406,7 +429,9 @@ testOwnerAdd o =
req <-
run $ testPostJson "/api/owner" (A.object ["payload" A..= A.toJSON o]) --`debug` show o
res <- httpLBS req
assert $ getResponseStatus res == created201
if opayconf o
then assert $ getResponseStatus res == internalServerError500
else assert $ getResponseStatus res == created201
testOrderAdd :: ZGoOrder -> Property
testOrderAdd o =
@ -438,13 +463,12 @@ closeDbConnection = close
handleDb :: (Pipe -> Expectation) -> IO ()
handleDb = bracket openDbConnection closeDbConnection
startAPI ::
T.Text -> SecureMem -> T.Text -> B.ByteString -> B.ByteString -> IO ()
startAPI db passkey nodeAddress nodeUser nodePwd = do
startAPI :: Config -> IO ()
startAPI config = do
putStrLn "Starting test server ..."
pipe <- connect $ host "127.0.0.1"
c <- access pipe master "zgo" (auth "zgo" "zcashrules")
let appRoutes = routes pipe db passkey nodeAddress nodeUser nodePwd
let appRoutes = routes pipe config
_ <- forkIO (scotty 3000 appRoutes)
let myUser =
User
@ -492,6 +516,8 @@ startAPI db passkey nodeAddress nodeUser nodePwd = do
False
False
(UTCTime (fromGregorian 2022 4 16) (secondsToDiffTime 0))
False
""
_ <- access pipe master "test" (Database.MongoDB.delete (select [] "owners"))
let o = val myOwner
case o of
@ -576,8 +602,11 @@ instance Arbitrary Owner where
paid <- arbitrary
zats <- arbitrary
inv <- arbitrary
exp <- arbitrary
payconf <- arbitrary
--exp <- arbitrary
Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv <$> arbitrary
Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv exp payconf <$>
arbitrary
instance Arbitrary Item where
arbitrary = do

12
zgotest.cfg Normal file
View File

@ -0,0 +1,12 @@
passkey = "superSecret"
nodeAddress = "zs1xnpqd2tae9d95f8fhe4l0q7j44a5vf993m0pcnnvr56uqr4lgqlamesk5v4c5rhtvywc6lvlduy"
dbHost = "127.0.0.1"
dbName = "test"
dbUser = "zgo"
dbPassword = "zcashrules"
nodeUser = "zecwallet"
nodePassword = "rdsxlun6v4a"
port = 3000
tls = false
certificate = "/path/to/cert.pem"
key = "/path/to/key.pem"