From c2be91dfcc9e7ae5acba3693e470485da1b3f840 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Fri, 13 Oct 2023 14:20:10 -0500 Subject: [PATCH] Add ZGo order parsing and payment tracking --- src/ZGoBackend.hs | 104 ++++++++++++++++++++++++++++++++++++++++------ src/ZGoTx.hs | 19 ++++++++- 2 files changed, 109 insertions(+), 14 deletions(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index d82a89c..2c7b787 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -1897,9 +1897,7 @@ scanTxNative config pipe = do unless (null keyOwnerList) $ do let nodeUser = c_nodeUser config let nodePwd = c_nodePwd config - let ownerList = cast' . Doc <$> keyOwnerList - let keyList = map (maybe "" oviewkey) ownerList - print keyList + let ownerList = mapMaybe (cast' . Doc) keyOwnerList lastBlockData <- access pipe master db findBlock latestBlock <- getBlockInfo nodeUser nodePwd "-1" case latestBlock of @@ -1921,7 +1919,7 @@ scanTxNative config pipe = do print "filtering txs..." let filteredTxList = map fromJust $ filter filterTx txList print "checking txs against keys..." - mapM_ (checkTx filteredTxList) keyList + mapM_ (checkTx filteredTxList) ownerList access pipe master (c_dbName config) $ upsertBlock lB Just lastBlock -> do blockList' <- @@ -1937,7 +1935,7 @@ scanTxNative config pipe = do print "filtering txs..." let filteredTxList = map fromJust $ filter filterTx txList print "checking txs against keys..." - mapM_ (checkTx filteredTxList) keyList + mapM_ (checkTx filteredTxList) ownerList access pipe master (c_dbName config) $ upsertBlock lB where filterBlock :: Maybe BlockResponse -> Bool @@ -1963,27 +1961,27 @@ scanTxNative config pipe = do else do print $ err content return Nothing - checkTx :: [RawTxResponse] -> T.Text -> IO () + checkTx :: [RawTxResponse] -> Owner -> IO () checkTx txList' k = do let sOutList = concatMap rt_shieldedOutputs txList' - if isValidSaplingViewingKey (E.encodeUtf8 k) + if isValidSaplingViewingKey (E.encodeUtf8 $ oviewkey k) then do print "decoding Sapling tx" - let decodedSapList' = concatMap (decodeSaplingTx k) txList' + let decodedSapList' = concatMap (decodeSaplingTx $ oviewkey k) txList' let zList = catMaybes decodedSapList' - mapM_ (zToZGoTx' config pipe) zList + mapM_ (recordPayment pipe (c_dbName config) (oaddress k)) zList else do - let vk = decodeUfvk $ E.encodeUtf8 k + let vk = decodeUfvk $ E.encodeUtf8 $ oviewkey k case vk of Nothing -> print "Not a valid key" Just v -> do let decodedSapList = concatMap (decodeUnifiedSaplingTx (s_key v)) txList' let zList' = catMaybes decodedSapList - mapM_ (zToZGoTx' config pipe) zList' + mapM_ (recordPayment pipe (c_dbName config) (oaddress k)) zList' let decodedOrchList = concatMap (decodeUnifiedOrchardTx v) txList' let oList = catMaybes decodedOrchList - mapM_ (zToZGoTx' config pipe) oList + mapM_ (recordPayment pipe (c_dbName config) (oaddress k)) oList decodeSaplingTx :: T.Text -> RawTxResponse -> [Maybe ZcashTx] decodeSaplingTx k t = map @@ -2012,6 +2010,88 @@ scanTxNative config pipe = do False (rt_confirmations t) (E.decodeUtf8Lenient $ a_memo n) + recordPayment :: Pipe -> T.Text -> T.Text -> ZcashTx -> IO () + recordPayment p dbName z x = do + let zM = runParser pZGoMemo (T.unpack . ztxid $ x) (zmemo x) + case zM of + Right m -> do + case m_orderId m of + Nothing -> return () + Just orderId -> do + o <- access p master dbName $ findOrderById (T.unpack orderId) + let xOrder = o >>= (cast' . Doc) + case xOrder of + Nothing -> error "Failed to retrieve order from database" + Just xO -> + when + (not (qpaid xO) && + qtotalZec xO == zamount 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 (T.unpack orderId, zamount 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 + (T.unpack orderId, zamount x) + else error + "Couldn't parse externalInvoice for WooCommerce" + _ -> putStrLn "Not an integration order" + else liftIO $ + access p master dbName $ + markOrderPaid (T.unpack orderId, zamount x) + Left e -> print "Unable to parse order memo" debug = flip trace diff --git a/src/ZGoTx.hs b/src/ZGoTx.hs index e453346..3749eb4 100644 --- a/src/ZGoTx.hs +++ b/src/ZGoTx.hs @@ -105,6 +105,7 @@ data ZGoMemo = ZGoMemo { m_session :: Maybe U.UUID , m_address :: Maybe T.Text , m_payment :: Bool + , m_orderId :: Maybe T.Text } deriving (Eq, Show) data MemoToken @@ -112,6 +113,7 @@ data MemoToken | PayMsg !U.UUID | Address !T.Text | Msg !T.Text + | OrderId !T.Text deriving (Show, Eq) type Parser = Parsec Void T.Text @@ -146,6 +148,12 @@ pUnifiedAddress = do then pure $ Address $ T.pack ("u1" <> a) else fail "Failed to parse Unified Address" +pOrderId :: Parser MemoToken +pOrderId = do + string "ZGo Order::" + a <- some hexDigitChar + pure $ OrderId . T.pack $ a + pMsg :: Parser MemoToken pMsg = do msg <- @@ -157,7 +165,7 @@ pMsg = do pMemo :: Parser MemoToken pMemo = do optional $ some spaceChar - t <- pSession <|> pSaplingAddress <|> pUnifiedAddress <|> pMsg + t <- pSession <|> pSaplingAddress <|> pUnifiedAddress <|> pOrderId <|> pMsg optional $ some spaceChar return t @@ -182,8 +190,15 @@ isMemoToken kind t = pZGoMemo :: Parser ZGoMemo pZGoMemo = do tks <- some pMemo - pure $ ZGoMemo (isSession tks) (isAddress tks) (isPayment tks) + pure $ ZGoMemo (isSession tks) (isAddress tks) (isPayment tks) (isOrder tks) where + isOrder [] = Nothing + isOrder tks = + if not (null tks) + then case head tks of + OrderId x -> Just x + _ -> isOrder $ tail tks + else Nothing isPayment [] = False isPayment tks = not (null tks) &&