From 738b28a4ef291e646774226e62259a972f60ac15 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 21 Jul 2022 12:14:27 -0500 Subject: [PATCH] Add functionality to save viewing key Includes improvements on error handling for RPC calls to the Zcash node. --- CHANGELOG.md | 2 + src/Order.hs | 6 ++ src/ZGoBackend.hs | 203 ++++++++++++++++++++++++++++++++++++++++++---- test/Spec.hs | 61 ++++++++++---- zgotest.cfg | 12 +++ 5 files changed, 250 insertions(+), 34 deletions(-) create mode 100644 zgotest.cfg diff --git a/CHANGELOG.md b/CHANGELOG.md index 5c0a091..a4b3830 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/src/Order.hs b/src/Order.hs index 986ac0e..94713cf 100644 --- a/src/Order.hs +++ b/src/Order.hs @@ -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]] diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index a3f9658..42c1dc2 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs index 9abc297..55c32f5 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 diff --git a/zgotest.cfg b/zgotest.cfg new file mode 100644 index 0000000..ca65231 --- /dev/null +++ b/zgotest.cfg @@ -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"