From 353c91204a642ca96cf27fbd45a1b0c05202f729 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Thu, 15 Jun 2023 08:55:39 -0500 Subject: [PATCH] Enhance payment confirmation logic --- CHANGELOG.md | 1 + src/Owner.hs | 4 ++ src/ZGoBackend.hs | 178 +++++++++++++++++++++++++--------------------- 3 files changed, 101 insertions(+), 82 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 92bddfd..d127dc7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -12,6 +12,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Changed +- Modified the process of scanning for payments to only scan addresses that have an active ZGo session and have enabled payment confirmations - Modified the process to mark paid orders to ensure only payments to the shop's wallet get marked as paid - Modified the `items` endpoint to use the login session to identify records diff --git a/src/Owner.hs b/src/Owner.hs index 867f923..267fa2e 100644 --- a/src/Owner.hs +++ b/src/Owner.hs @@ -407,6 +407,10 @@ findOwnerById :: T.Text -> Action IO (Maybe Document) findOwnerById i = findOne (select ["_id" =: (read (T.unpack i) :: ObjectId)] "owners") +findActiveOwners :: Action IO [Document] +findActiveOwners = + rest =<< find (select ["paid" =: True, "payconf" =: True] "owners") + -- | Function to find Owners about to expire findExpiringOwners :: UTCTime -> Action IO [Document] findExpiringOwners now = diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 7ba2709..52e9ae5 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -1386,88 +1386,102 @@ scanZcash' config pipe = do -- | 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_ (recordPayment p (c_dbName config) z) j - Left e -> print e - getOrderId :: Text.Regex.Regex -> ZcashTx -> (String, Double) - getOrderId re t = do - let reg = matchAllText re (T.unpack $ zmemo t) - if not (null reg) - then (fst $ head reg ! 1, zamount t) - else ("", 0) - recordPayment :: Pipe -> T.Text -> ZcashAddress -> (String, Double) -> IO () - recordPayment p dbName z x = do - o <- access p master dbName $ findOrderById (fst x) - let xOrder = o >>= (cast' . Doc) - case xOrder of - Nothing -> error "Failed to retrieve order from database" - Just xO -> - when - (not (qpaid xO) && - qexternalInvoice xO /= "" && - qtotalZec xO == snd x && addy z == qaddress xO) $ do - let sReg = mkRegex "(.*)-([a-fA-f0-9]{24})" - let sResult = matchAllText sReg (T.unpack $ qsession xO) - if not (null sResult) - then case fst $ head sResult ! 1 of - "Xero" -> do - xeroConfig <- access p master dbName findXero - let xC = xeroConfig >>= (cast' . Doc) - case xC of - Nothing -> error "Failed to read Xero config" - Just xConf -> do - requestXeroToken p dbName xConf "" (qaddress xO) - payXeroInvoice - p - dbName - (qexternalInvoice xO) - (qaddress xO) - (qtotal xO) - (qtotalZec xO) - liftIO $ access p master dbName $ markOrderPaid x - "WC" -> do - let wOwner = fst $ head sResult ! 2 - wooT <- - access p master dbName $ - findWooToken $ Just (read wOwner) - let wT = wooT >>= (cast' . Doc) - case wT of - Nothing -> error "Failed to read WooCommerce token" - Just wt -> do - let iReg = mkRegex "(.*)-(.*)-.*" - let iResult = - matchAllText - iReg - (T.unpack $ qexternalInvoice xO) - if not (null iResult) - then do - let wUrl = - E.decodeUtf8With lenientDecode . - B64.decodeLenient . C.pack $ - fst $ head iResult ! 1 - let iNum = fst $ head iResult ! 2 - payWooOrder - (T.unpack wUrl) - (C.pack iNum) - (C.pack $ maybe "" show (q_id xO)) - (C.pack . T.unpack $ w_token wt) - (C.pack . show $ qprice xO) - (C.pack . show $ qtotalZec xO) - liftIO $ access p master dbName $ markOrderPaid x - else error - "Couldn't parse externalInvoice for WooCommerce" - _ -> putStrLn "Not an integration order" - else putStrLn "Not an integration order" + shopRecords <- access pipe master (c_dbName config) findActiveOwners + case shopRecords of + [] -> return () + _ -> do + let shops = cast' . Doc <$> shopRecords :: [Maybe Owner] + let validShopAddresses = map (maybe "" oaddress) $ filter isJust shops + mapM_ (findPaidOrders config pipe) validShopAddresses + where findPaidOrders :: Config -> Pipe -> T.Text -> IO () + findPaidOrders c p z = do + paidTxs <- listTxs (c_nodeUser c) (c_nodePwd c) 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_ (recordPayment p (c_dbName config) z) j + Left e -> print e + getOrderId :: Text.Regex.Regex -> ZcashTx -> (String, Double) + getOrderId re t = do + let reg = matchAllText re (T.unpack $ zmemo t) + if not (null reg) + then (fst $ head reg ! 1, zamount t) + else ("", 0) + recordPayment :: + Pipe -> T.Text -> T.Text -> (String, Double) -> IO () + recordPayment p dbName z x = do + o <- access p master dbName $ findOrderById (fst x) + let xOrder = o >>= (cast' . Doc) + case xOrder of + Nothing -> error "Failed to retrieve order from database" + Just xO -> + when + (not (qpaid xO) && + qexternalInvoice xO /= "" && + qtotalZec xO == snd x && z == qaddress xO) $ do + let sReg = mkRegex "(.*)-([a-fA-f0-9]{24})" + let sResult = matchAllText sReg (T.unpack $ qsession xO) + if not (null sResult) + then case fst $ head sResult ! 1 of + "Xero" -> do + xeroConfig <- access p master dbName findXero + let xC = xeroConfig >>= (cast' . Doc) + case xC of + Nothing -> error "Failed to read Xero config" + Just xConf -> do + requestXeroToken + p + dbName + xConf + "" + (qaddress xO) + payXeroInvoice + p + dbName + (qexternalInvoice xO) + (qaddress xO) + (qtotal xO) + (qtotalZec xO) + liftIO $ + access p master dbName $ markOrderPaid x + "WC" -> do + let wOwner = fst $ head sResult ! 2 + wooT <- + access p master dbName $ + findWooToken $ Just (read wOwner) + let wT = wooT >>= (cast' . Doc) + case wT of + Nothing -> + error "Failed to read WooCommerce token" + Just wt -> do + let iReg = mkRegex "(.*)-(.*)-.*" + let iResult = + matchAllText + iReg + (T.unpack $ qexternalInvoice xO) + if not (null iResult) + then do + let wUrl = + E.decodeUtf8With lenientDecode . + B64.decodeLenient . C.pack $ + fst $ head iResult ! 1 + let iNum = fst $ head iResult ! 2 + payWooOrder + (T.unpack wUrl) + (C.pack iNum) + (C.pack $ maybe "" show (q_id xO)) + (C.pack . T.unpack $ w_token wt) + (C.pack . show $ qprice xO) + (C.pack . show $ qtotalZec xO) + liftIO $ + access p master dbName $ + markOrderPaid x + else error + "Couldn't parse externalInvoice for WooCommerce" + _ -> putStrLn "Not an integration order" + else putStrLn "Not an integration order" -- | RPC methods -- | List addresses with viewing keys loaded