Add ZGo order parsing and payment tracking

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 ownerList = mapMaybe (cast' . Doc) keyOwnerList
-    let keyList = map (maybe "" oviewkey) ownerList
-    print keyList
     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
 

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) &&