Vergara_Tech/zgo-backend
Vergara_Tech/zgo-backend
2
1
Fork 0
Code Issues Pull requests Projects Releases 4 Packages Wiki Activity

Enhance payment confirmation logic

Browse source
This commit is contained in:
Rene Vergara 2023-06-15 08:55:39 -05:00
parent c2fc8b8ae9
commit 353c91204a
Signed by: pitmutt
GPG key ID: 65122AD495A7F5B2
3 changed files with 101 additions and 82 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
CHANGELOG.md
View file

@ -12,6 +12,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
### Changed ### 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 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 - Modified the `items` endpoint to use the login session to identify records

4
src/Owner.hs
View file

@ -407,6 +407,10 @@ findOwnerById :: T.Text -> Action IO (Maybe Document)
findOwnerById i = findOwnerById i =
findOne (select ["_id" =: (read (T.unpack i) :: ObjectId)] "owners") 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 -- | Function to find Owners about to expire
findExpiringOwners :: UTCTime -> Action IO [Document] findExpiringOwners :: UTCTime -> Action IO [Document]
findExpiringOwners now = findExpiringOwners now =

178
src/ZGoBackend.hs
View file

@ -1386,88 +1386,102 @@ scanZcash' config pipe = do
-- | Function to scan loaded viewing keys for payments -- | Function to scan loaded viewing keys for payments
scanPayments :: Config -> Pipe -> IO () scanPayments :: Config -> Pipe -> IO ()
scanPayments config pipe = do scanPayments config pipe = do
shops <- listAddresses (c_nodeUser config) (c_nodePwd config) shopRecords <- access pipe master (c_dbName config) findActiveOwners
mapM_ (findPaidOrders config pipe) shops case shopRecords of
where [] -> return ()
findPaidOrders :: Config -> Pipe -> ZcashAddress -> IO () _ -> do
findPaidOrders c p z = do let shops = cast' . Doc <$> shopRecords :: [Maybe Owner]
paidTxs <- listTxs (c_nodeUser c) (c_nodePwd c) (addy z) 5 let validShopAddresses = map (maybe "" oaddress) $ filter isJust shops
case paidTxs of mapM_ (findPaidOrders config pipe) validShopAddresses
Right txs -> do where findPaidOrders :: Config -> Pipe -> T.Text -> IO ()
let r = mkRegex ".*ZGo Order::([0-9a-fA-F]{24}).*" findPaidOrders c p z = do
let k = filter (isRelevant r) txs paidTxs <- listTxs (c_nodeUser c) (c_nodePwd c) z 5
let j = map (getOrderId r) k case paidTxs of
mapM_ (recordPayment p (c_dbName config) z) j Right txs -> do
Left e -> print e let r = mkRegex ".*ZGo Order::([0-9a-fA-F]{24}).*"
getOrderId :: Text.Regex.Regex -> ZcashTx -> (String, Double) let k = filter (isRelevant r) txs
getOrderId re t = do let j = map (getOrderId r) k
let reg = matchAllText re (T.unpack $ zmemo t) mapM_ (recordPayment p (c_dbName config) z) j
if not (null reg) Left e -> print e
then (fst $ head reg ! 1, zamount t) getOrderId :: Text.Regex.Regex -> ZcashTx -> (String, Double)
else ("", 0) getOrderId re t = do
recordPayment :: Pipe -> T.Text -> ZcashAddress -> (String, Double) -> IO () let reg = matchAllText re (T.unpack $ zmemo t)
recordPayment p dbName z x = do if not (null reg)
o <- access p master dbName $ findOrderById (fst x) then (fst $ head reg ! 1, zamount t)
let xOrder = o >>= (cast' . Doc) else ("", 0)
case xOrder of recordPayment ::
Nothing -> error "Failed to retrieve order from database" Pipe -> T.Text -> T.Text -> (String, Double) -> IO ()
Just xO -> recordPayment p dbName z x = do
when o <- access p master dbName $ findOrderById (fst x)
(not (qpaid xO) && let xOrder = o >>= (cast' . Doc)
qexternalInvoice xO /= "" && case xOrder of
qtotalZec xO == snd x && addy z == qaddress xO) $ do Nothing -> error "Failed to retrieve order from database"
let sReg = mkRegex "(.*)-([a-fA-f0-9]{24})" Just xO ->
let sResult = matchAllText sReg (T.unpack $ qsession xO) when
if not (null sResult) (not (qpaid xO) &&
then case fst $ head sResult ! 1 of qexternalInvoice xO /= "" &&
"Xero" -> do qtotalZec xO == snd x && z == qaddress xO) $ do
xeroConfig <- access p master dbName findXero let sReg = mkRegex "(.*)-([a-fA-f0-9]{24})"
let xC = xeroConfig >>= (cast' . Doc) let sResult = matchAllText sReg (T.unpack $ qsession xO)
case xC of if not (null sResult)
Nothing -> error "Failed to read Xero config" then case fst $ head sResult ! 1 of
Just xConf -> do "Xero" -> do
requestXeroToken p dbName xConf "" (qaddress xO) xeroConfig <- access p master dbName findXero
payXeroInvoice let xC = xeroConfig >>= (cast' . Doc)
p case xC of
dbName Nothing -> error "Failed to read Xero config"
(qexternalInvoice xO) Just xConf -> do
(qaddress xO) requestXeroToken
(qtotal xO) p
(qtotalZec xO) dbName
liftIO $ access p master dbName $ markOrderPaid x xConf
"WC" -> do ""
let wOwner = fst $ head sResult ! 2 (qaddress xO)
wooT <- payXeroInvoice
access p master dbName $ p
findWooToken $ Just (read wOwner) dbName
let wT = wooT >>= (cast' . Doc) (qexternalInvoice xO)
case wT of (qaddress xO)
Nothing -> error "Failed to read WooCommerce token" (qtotal xO)
Just wt -> do (qtotalZec xO)
let iReg = mkRegex "(.*)-(.*)-.*" liftIO $
let iResult = access p master dbName $ markOrderPaid x
matchAllText "WC" -> do
iReg let wOwner = fst $ head sResult ! 2
(T.unpack $ qexternalInvoice xO) wooT <-
if not (null iResult) access p master dbName $
then do findWooToken $ Just (read wOwner)
let wUrl = let wT = wooT >>= (cast' . Doc)
E.decodeUtf8With lenientDecode . case wT of
B64.decodeLenient . C.pack $ Nothing ->
fst $ head iResult ! 1 error "Failed to read WooCommerce token"
let iNum = fst $ head iResult ! 2 Just wt -> do
payWooOrder let iReg = mkRegex "(.*)-(.*)-.*"
(T.unpack wUrl) let iResult =
(C.pack iNum) matchAllText
(C.pack $ maybe "" show (q_id xO)) iReg
(C.pack . T.unpack $ w_token wt) (T.unpack $ qexternalInvoice xO)
(C.pack . show $ qprice xO) if not (null iResult)
(C.pack . show $ qtotalZec xO) then do
liftIO $ access p master dbName $ markOrderPaid x let wUrl =
else error E.decodeUtf8With lenientDecode .
"Couldn't parse externalInvoice for WooCommerce" B64.decodeLenient . C.pack $
_ -> putStrLn "Not an integration order" fst $ head iResult ! 1
else putStrLn "Not an integration order" 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 -- | RPC methods
-- | List addresses with viewing keys loaded -- | List addresses with viewing keys loaded