Add functionality to save viewing key

Includes improvements on error handling for RPC calls to the Zcash node.

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

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

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)
+    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,9 +720,10 @@ scanZcash config pipe = do
       (c_nodePwd config)
       "z_listreceivedbyaddress"
       [Data.Aeson.String (c_nodeAddress config)]
-  let txs =
+  let content = getResponseBody res :: RpcResponse [ZcashTx]
-        filter (not . zchange) $
+  case err content of
-        result (getResponseBody res :: RpcResponse [ZcashTx])
+    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}).*"
@@ -587,12 +734,32 @@ scanZcash config pipe = do
       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

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"]
+  loadedConfig <- loadZGoConfig "zgotest.cfg"
-  let dbName = "test"
-  nodeAddress <- require config "nodeAddress"
-  nodeUser <- require config "nodeUser"
-  nodePwd <- require config "nodePassword"
-  passkey <- secureMemFromByteString <$> require config "passkey"
   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 ::
+startAPI :: Config -> IO ()
-     T.Text -> SecureMem -> T.Text -> B.ByteString -> B.ByteString -> IO ()
+startAPI config = do
-startAPI db passkey nodeAddress nodeUser nodePwd = 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

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"