Alpha version of native Tx scanning

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]
 

src/Owner.hs

@@ -14,8 +14,7 @@ import Database.MongoDB
 import GHC.Generics
 
 -- | Type to represent a ZGo shop owner/business
-data Owner =
-  Owner
+data Owner = Owner
   { o_id :: Maybe ObjectId
   , oaddress :: T.Text
   , oname :: T.Text
@@ -41,8 +40,7 @@ data Owner =
   , opayconf :: Bool
   , oviewkey :: T.Text
   , ocrmToken :: T.Text
-    }
-  deriving (Eq, Show, Generic, Typeable)
+  } deriving (Eq, Show, Generic, Typeable)
 
 instance ToJSON Owner where
   toJSON (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv eTs pc vk cT) =
@@ -276,8 +274,7 @@ instance Val Owner where
           ]
 
 -- | Type to represent informational data for Owners from UI
-data OwnerData =
-  OwnerData
+data OwnerData = OwnerData
   { od_first :: T.Text
   , od_last :: T.Text
   , od_name :: T.Text
@@ -289,8 +286,7 @@ data OwnerData =
   , od_email :: T.Text
   , od_website :: T.Text
   , od_phone :: T.Text
-    }
-  deriving (Eq, Show, Generic)
+  } deriving (Eq, Show, Generic)
 
 instance FromJSON OwnerData where
   parseJSON =
@@ -308,8 +304,7 @@ instance FromJSON OwnerData where
       ph <- obj .: "phone"
       pure $ OwnerData f l n s c st p co e w ph
 
-data OwnerSettings =
-  OwnerSettings
+data OwnerSettings = OwnerSettings
   { os_id :: Maybe ObjectId
   , os_address :: T.Text
   , os_name :: T.Text
@@ -325,8 +320,7 @@ data OwnerSettings =
   , os_payconf :: Bool
   , os_crmToken :: T.Text
   , os_viewKey :: T.Text
-    }
-  deriving (Eq, Show, Generic)
+  } deriving (Eq, Show, Generic)
 
 instance FromJSON OwnerSettings where
   parseJSON =
@@ -424,6 +418,11 @@ findExpiringOwners now =
        ["paid" =: True, "expiration" =: ["$lte" =: addUTCTime 172800 now]]
        "owners")
 
+findWithKeys :: Action IO [Document]
+findWithKeys =
+  rest =<<
+  find (select ["paid" =: True, "invoices" =: True, "payconf" =: True] "owners")
+
 removePro :: T.Text -> Action IO ()
 removePro o =
   modify (select ["address" =: o] "owners") ["$set" =: ["invoices" =: False]]
@@ -450,14 +449,12 @@ upsertViewingKey o vk =
   modify (select ["_id" =: o_id o] "owners") ["$set" =: ["viewKey" =: vk]]
 
 -- | Type for a pro session
-data ZGoProSession =
-  ZGoProSession
+data ZGoProSession = ZGoProSession
   { ps_id :: Maybe ObjectId
   , psaddress :: T.Text
   , psexpiration :: UTCTime
   , psclosed :: Bool
-    }
-  deriving (Eq, Show)
+  } deriving (Eq, Show)
 
 instance Val ZGoProSession where
   cast' (Doc d) = do

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

src/ZGoTx.hs

@@ -9,16 +9,18 @@ import qualified Data.Bson as B
 import Data.Char
 import Data.Maybe
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as E
 import qualified Data.UUID as U
 import Data.Void
 import Database.MongoDB
 import GHC.Generics
 import Text.Megaparsec hiding (State)
 import Text.Megaparsec.Char
+import ZcashHaskell.Orchard
+import ZcashHaskell.Sapling (isValidShieldedAddress)
 
 -- | Type to model a ZGo transaction
-data ZGoTx =
-  ZGoTx
+data ZGoTx = ZGoTx
   { _id :: Maybe ObjectId
   , address :: T.Text
   , session :: T.Text
@@ -27,8 +29,7 @@ data ZGoTx =
   , amount :: Double
   , txid :: T.Text
   , memo :: T.Text
-    }
-  deriving (Eq, Show, Generic)
+  } deriving (Eq, Show, Generic)
 
 parseZGoTxBson :: B.Document -> Maybe ZGoTx
 parseZGoTxBson d = do
@@ -100,13 +101,11 @@ instance Val ZGoTx where
           ]
 
 -- | Type to represent and parse ZGo memos
-data ZGoMemo =
-  ZGoMemo
+data ZGoMemo = ZGoMemo
   { m_session :: Maybe U.UUID
   , m_address :: Maybe T.Text
   , m_payment :: Bool
-    }
-  deriving (Eq, Show)
+  } deriving (Eq, Show)
 
 data MemoToken
   = Login !U.UUID
@@ -135,9 +134,17 @@ pSaplingAddress :: Parser MemoToken
 pSaplingAddress = do
   string "zs"
   a <- some alphaNumChar
-  if length a /= 76
-    then fail "Failed to parse Sapling address"
-    else pure $ Address $ T.pack ("zs" <> a)
+  if isValidShieldedAddress (E.encodeUtf8 $ "zs" <> T.pack a)
+    then pure $ Address $ T.pack ("zs" <> a)
+    else fail "Failed to parse Sapling address"
+
+pUnifiedAddress :: Parser MemoToken
+pUnifiedAddress = do
+  string "u1"
+  a <- some alphaNumChar
+  if isValidUnifiedAddress (E.encodeUtf8 $ "u1" <> T.pack a)
+    then pure $ Address $ T.pack ("u1" <> a)
+    else fail "Failed to parse Unified Address"
 
 pMsg :: Parser MemoToken
 pMsg = do

stack.yaml

@@ -45,7 +45,7 @@ extra-deps:
   - git: https://github.com/reach-sh/haskell-hexstring.git
     commit: 085c16fb21b9f856a435a3faab980e7e0b319341
   - git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
-    commit: fef3d3af35a09db718cddb8fc9166b2d2691a744
+    commit: d78c269d96fe7d8a626cf701b8051c40f251e232
   - git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git
     commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05
   - git: https://github.com/well-typed/borsh.git

stack.yaml.lock

@@ -16,15 +16,15 @@ packages:
     commit: 085c16fb21b9f856a435a3faab980e7e0b319341
     git: https://github.com/reach-sh/haskell-hexstring.git
 - completed:
-    commit: fef3d3af35a09db718cddb8fc9166b2d2691a744
+    commit: d78c269d96fe7d8a626cf701b8051c40f251e232
     git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
     name: zcash-haskell
     pantry-tree:
-      sha256: ec7782cf2646da17548d59af0ea98dcbaac1b6c2176258c696a7f508db6dbc21
-      size: 1126
-    version: 0.1.0
+      sha256: 69201a27ac966be478ef0b8e3fa8e8bf5cbcc67a58cd254326545eb4f3e93569
+      size: 1229
+    version: 0.2.0
   original:
-    commit: fef3d3af35a09db718cddb8fc9166b2d2691a744
+    commit: d78c269d96fe7d8a626cf701b8051c40f251e232
     git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git
 - completed:
     commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05

test/Spec.hs

@@ -59,7 +59,7 @@ main = do
       describe "Memo parsers" $
         --prop "memo parsing" testMemoParser
        do
-        it "parse ZecWallet memo" $ do
+        it "parse ZecWallet memo - Sapling" $ do
           let m =
                 runParser
                   pZGoMemo
@@ -70,7 +70,7 @@ main = do
             Right m' ->
               m_session m' `shouldBe`
               U.fromString "5d3d4494-51c0-432d-8495-050419957aea"
-        it "parse YWallet memo" $ do
+        it "parse YWallet memo - Sapling" $ do
           let m =
                 runParser
                   pZGoMemo
@@ -81,7 +81,7 @@ main = do
             Right m' ->
               m_session m' `shouldBe`
               U.fromString "ad8477d3-4fdd-4c97-90b2-76630b5f77e1"
-        it "parse Zingo memo" $ do
+        it "parse Zingo memo - Sapling" $ do
           let m =
                 runParser
                   pZGoMemo
@@ -92,6 +92,39 @@ main = do
             Right m' ->
               m_session m' `shouldBe`
               U.fromString "5d3d4494-51c0-432d-8495-050419957aea"
+        it "parse ZecWallet memo - Orchard" $ do
+          let m =
+                runParser
+                  pZGoMemo
+                  "Zecwalllet memo"
+                  "ZGO::5d3d4494-51c0-432d-8495-050419957aea\nReply-To:\nu17n7hpwaujyq7ux8f9jpyymtnk5urw7pyrf60smp5mawy7jgz325hfvz3jn3zsfya8yxryf9q7ldk8nu8df0emra5wne28zq9d9nm2pu4x6qwjha565av9aze0xgujgslz74ufkj0c0cylqwjyrh9msjfh7jzal6d3qzrnhkkqy3pqm8j63y07jxj7txqeac982778rmt64f32aum94x"
+          case m of
+            Left e -> putStrLn $ errorBundlePretty e
+            Right m' ->
+              m_session m' `shouldBe`
+              U.fromString "5d3d4494-51c0-432d-8495-050419957aea"
+        it "parse YWallet memo - Orchard" $ do
+          let m =
+                runParser
+                  pZGoMemo
+                  "Ywallet memo"
+                  "\128737MSG\nu17n7hpwaujyq7ux8f9jpyymtnk5urw7pyrf60smp5mawy7jgz325hfvz3jn3zsfya8yxryf9q7ldk8nu8df0emra5wne28zq9d9nm2pu4x6qwjha565av9aze0xgujgslz74ufkj0c0cylqwjyrh9msjfh7jzal6d3qzrnhkkqy3pqm8j63y07jxj7txqeac982778rmt64f32aum94x\n\nZGO::ad8477d3-4fdd-4c97-90b2-76630b5f77e1"
+          case m of
+            Left e -> putStrLn $ errorBundlePretty e
+            Right m' ->
+              m_session m' `shouldBe`
+              U.fromString "ad8477d3-4fdd-4c97-90b2-76630b5f77e1"
+        it "parse Zingo memo - Orchard" $ do
+          let m =
+                runParser
+                  pZGoMemo
+                  "Zingo memo"
+                  "ZGO::5d3d4494-51c0-432d-8495-050419957aea\nReply to:\nu17n7hpwaujyq7ux8f9jpyymtnk5urw7pyrf60smp5mawy7jgz325hfvz3jn3zsfya8yxryf9q7ldk8nu8df0emra5wne28zq9d9nm2pu4x6qwjha565av9aze0xgujgslz74ufkj0c0cylqwjyrh9msjfh7jzal6d3qzrnhkkqy3pqm8j63y07jxj7txqeac982778rmt64f32aum94x"
+          case m of
+            Left e -> putStrLn $ errorBundlePretty e
+            Right m' ->
+              m_session m' `shouldBe`
+              U.fromString "5d3d4494-51c0-432d-8495-050419957aea"
       describe "PIN generator" $ do
         it "should give a 7 digit" $ do
           pin <- generatePin
@@ -262,7 +295,7 @@ main = do
           it "return owner by id" $ do
             req <-
               testGet
-                "/api/ownerid"
+                "/ownerid"
                 [ ("id", Just "627ad3492b05a76be3000001")
                 , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
                 ]