Enhance payment confirmation logic
This commit is contained in:
parent
c2fc8b8ae9
commit
353c91204a
GPG key ID:
65122AD495A7F5B2
3 changed files with 101 additions and 82 deletions
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue