Add ZGo order parsing and payment tracking
This commit is contained in:
parent
d7ced42d86
commit
c2be91dfcc
GPG Key ID:
65122AD495A7F5B2
|
|
@ -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
|
||||
|
||||
|
|
|
|||
19
src/ZGoTx.hs
19
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) &&
|
||||
|
|
|
|||
Loading…
Reference in New Issue