Implement marking of orders as paid

CHANGELOG.md

@@ -8,6 +8,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
 
 ### Added
 
+- New functionality to read transactions for the given viewing keys
+- New functionality to mark orders as paid once payment is found on-chain
 - New `Config` type to house the configuration parameters
 - New field in `Owner` type to store toggle for payment confirmation
 - New field in `Owner` type to store viewing key

app/Main.hs

@@ -32,6 +32,7 @@ main = do
     else fail "MongoDB connection failed!"
   _ <- forkIO (setInterval 60 (checkZcashPrices pipe (c_dbName loadedConfig)))
   _ <- forkIO (setInterval 75 (scanZcash loadedConfig pipe))
+  _ <- forkIO (setInterval 90 (scanPayments loadedConfig pipe))
   _ <- forkIO (setInterval 60 (checkPayments pipe (c_dbName loadedConfig)))
   _ <- forkIO (setInterval 60 (expireOwners pipe (c_dbName loadedConfig)))
   _ <- forkIO (setInterval 60 (updateLogins pipe loadedConfig))

package.yaml

@@ -50,6 +50,7 @@ library:
   - warp-tls
   - hexstring
   - configurator
+  - scientific
 
 executables:
   zgo-backend-exe:

src/ZGoBackend.hs

@@ -18,6 +18,7 @@ import Data.Char
 import qualified Data.HashMap.Strict as HM
 import Data.HexString
 import Data.Maybe
+import qualified Data.Scientific as Scientific
 import Data.SecureMem
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as E
@@ -137,11 +138,19 @@ instance FromJSON ZcashTx where
       aZ <- obj .: "amountZat"
       bh <- obj .: "blockheight"
       bt <- obj .: "blocktime"
-      c <- obj .: "change"
+      c <- obj .:? "change"
       conf <- obj .: "confirmations"
       m <- obj .: "memo"
       pure $
-        ZcashTx t a aZ bh bt c conf (T.filter (/= '\NUL') $ decodeHexText m)
+        ZcashTx
+          t
+          a
+          aZ
+          bh
+          bt
+          (fromMaybe False c)
+          conf
+          (T.filter (/= '\NUL') $ decodeHexText m)
 
 instance ToJSON ZcashTx where
   toJSON (ZcashTx t a aZ bh bt c conf m) =
@@ -315,8 +324,8 @@ zToZGoTx (ZcashTx t a aZ bh bt c conf m) = do
   if not (null reg)
     then do
       let sess = T.pack (fst $ head reg ! 1)
-      let addy = T.pack (fst $ head reg ! 2)
-      ZGoTx Nothing addy sess conf bt a t m
+      let nAddy = T.pack (fst $ head reg ! 2)
+      ZGoTx Nothing nAddy sess conf bt a t m
     else do
       if not (null reg2)
         then do
@@ -711,19 +720,34 @@ checkZcashPrices p db = do
   q <- getZcashPrices
   mapM_ (access p master db) (updatePrices (getResponseBody q))
 
+-- | Function to search for transactions for an address
+listTxs ::
+     BS.ByteString
+  -> BS.ByteString
+  -> T.Text
+  -> Integer
+  -> IO (Either T.Text [ZcashTx])
+listTxs user pwd a confs = do
+  res <-
+    liftIO $
+    makeZcashCall
+      user
+      pwd
+      "z_listreceivedbyaddress"
+      [Data.Aeson.String a, Data.Aeson.Number $ Scientific.scientific confs 0]
+  let content = getResponseBody res :: RpcResponse [ZcashTx]
+  case err content of
+    Nothing ->
+      return $ Right $ filter (not . zchange) $ fromMaybe [] $ result content
+    Just e -> return $ Left $ "Error reading transactions: " <> emessage e
+
 -- | Function to check the ZGo full node for new txs
 scanZcash :: Config -> Pipe -> IO ()
 scanZcash config pipe = do
-  res <-
-    makeZcashCall
-      (c_nodeUser config)
-      (c_nodePwd config)
-      "z_listreceivedbyaddress"
-      [Data.Aeson.String (c_nodeAddress config)]
-  let content = getResponseBody res :: RpcResponse [ZcashTx]
-  case err content of
-    Nothing -> do
-      let txs = filter (not . zchange) $ fromMaybe [] $ result content
+  myTxs <-
+    listTxs (c_nodeUser config) (c_nodePwd config) (c_nodeAddress config) 1
+  case myTxs of
+    Right txs -> do
       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}).*"
@@ -734,15 +758,40 @@ 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)
+    Left e -> do
+      putStrLn $ "Error scanning node transactions: " ++ T.unpack e
       return ()
-  where
+
+-- | Function to filter transactions
 isRelevant :: Text.Regex.Regex -> ZcashTx -> Bool
 isRelevant re t
   | zconfirmations t < 10 && (matchTest re . T.unpack . zmemo) t = True
   | otherwise = False
 
+-- | Function to scan loaded viewing keys for payments
+scanPayments :: Config -> Pipe -> IO ()
+scanPayments config pipe = do
+  shops <- listAddresses (c_nodeUser config) (c_nodePwd config)
+  mapM_ (findPaidOrders config pipe) shops
+  where
+    findPaidOrders :: Config -> Pipe -> ZcashAddress -> IO ()
+    findPaidOrders c p z = do
+      paidTxs <- listTxs (c_nodeUser c) (c_nodePwd c) (addy z) 5
+      case paidTxs of
+        Right txs -> do
+          let r = mkRegex ".*ZGo Order::([0-9a-fA-F]{24}).*"
+          let k = filter (isRelevant r) txs
+          let j = map (getOrderId r) k
+          mapM_ (access p master (c_dbName config) . markOrderPaid) j
+        Left e -> putStrLn $ T.unpack e
+    getOrderId :: Text.Regex.Regex -> ZcashTx -> String
+    getOrderId re t = do
+      let reg = matchAllText re (T.unpack $ zmemo t)
+      if not (null reg)
+        then do
+          fst $ head reg ! 1
+        else ""
+
 -- | RPC methods
 -- | List addresses with viewing keys loaded
 listAddresses :: BS.ByteString -> BS.ByteString -> IO [ZcashAddress]

zgo-backend.cabal

@@ -54,6 +54,7 @@ library
     , random
     , regex-base
     , regex-compat
+    , scientific
     , scotty
     , securemem
     , text