Fix bug #2

CHANGELOG.md

@@ -16,7 +16,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
 ### Changed
 
 - Refactored code for requesting Xero tokens to make it reusable.
-- Change API authentication to allow for endpoints that don't require an `Authorization` header to support the WooCommerce integration
+- Changed API authentication to allow for endpoints that don't require an `Authorization` header to support the WooCommerce integration
+- Enhanced the on-chain order confirmation functionality to support WooCommerce integration and future integrations.
 
 ## [1.1.1] - 2022-10-08
 

src/WooCommerce.hs

@@ -4,6 +4,7 @@ module WooCommerce where
 
 import Data.Aeson
 import qualified Data.Bson as B
+import qualified Data.ByteString as BS
 import qualified Data.ByteString.Base64 as B64
 import qualified Data.ByteString.Char8 as C
 import Data.Maybe
@@ -11,6 +12,8 @@ import qualified Data.Text as T
 import qualified Data.Text.Encoding as E
 import Data.Text.Encoding.Error (lenientDecode)
 import Database.MongoDB
+import Network.HTTP.Simple
+import Network.HTTP.Types.Status
 
 -- | Type to represent the WooCommerce token
 data WooToken =
@@ -47,3 +50,28 @@ findWooToken oid = findOne (select ["owner" =: oid] "wootokens")
 addUrl :: WooToken -> T.Text -> Action IO ()
 addUrl t u =
   modify (select ["_id" =: w_id t] "wootokens") ["$set" =: ["url" =: u]]
+
+payWooOrder ::
+     String -- url
+  -> BS.ByteString -- WooCommerce order ID
+  -> BS.ByteString -- ZGo order id
+  -> BS.ByteString -- ZGo token
+  -> BS.ByteString -- Zcash price
+  -> BS.ByteString -- Total ZEC for order
+  -> IO ()
+payWooOrder u i o t p z = do
+  wooReq <- parseRequest $ u ++ "/wc-api/zpmtcallback"
+  let req =
+        setRequestQueryString
+          [ ("token", Just t)
+          , ("orderid", Just o)
+          , ("wc_orderid", Just i)
+          , ("rate", Just p)
+          , ("totalzec", Just z)
+          ]
+          wooReq
+  print req
+  res <- httpLBS req
+  if getResponseStatus res == ok200
+    then return ()
+    else error "Failed to report payment to WooCommerce"

src/Xero.hs

@@ -438,6 +438,6 @@ payXeroInvoice pipe dbName inv address amt = do
             setRequestPath "/api.xro/2.0/Payments" $
             setRequestHost "api.xero.com" $
             setRequestMethod "PUT" defaultRequest
-      res <- httpJSON req
-      print (res :: Response Object)
+      res <- httpJSON req :: IO (Response Object)
+      return ()
     else error "Invalid parameters"

src/ZGoBackend.hs

@@ -8,6 +8,7 @@ module ZGoBackend where
 
 import Config
 import Control.Concurrent (forkIO, threadDelay)
+import Control.Exception (try)
 import Control.Monad
 import Control.Monad.IO.Class
 import Data.Aeson
@@ -38,7 +39,6 @@ import Debug.Trace
 import GHC.Generics
 import Item
 import Network.HTTP.Simple
-import Network.HTTP.Types (created201)
 import Network.HTTP.Types.Status
 import Network.Wai (Request, pathInfo)
 import Network.Wai.Middleware.Cors
@@ -619,6 +619,21 @@ routes pipe config = do
     c <- param "code"
     liftAndCatchIO $ run (addAccCode oAdd c)
     status accepted202
+  -- Get the WooCommerce token
+  get "/api/wootoken" $ do
+    oid <- param "ownerid"
+    res <- liftAndCatchIO $ run (findWooToken (read oid))
+    let t1 = cast' . Doc =<< res
+    case t1 of
+      Nothing -> status noContent204
+      Just t -> do
+        status ok200
+        Web.Scotty.json
+          (object
+             [ "ownerid" .= show (w_owner t)
+             , "token" .= w_token t
+             , "siteurl" .= w_url t
+             ])
   -- Authenticate the WooCommerce plugin
   get "/auth" $ do
     oid <- param "ownerid"
@@ -644,14 +659,26 @@ routes pipe config = do
                         , "message" .= ("Authorized!" :: String)
                         ])
                  else do
-                   status accepted202
-                   Web.Scotty.json
-                     (object
-                        [ "authorized" .= False
-                        , "message" .=
-                          ("ZGo shop already linked to" <>
-                           fromMaybe "" (w_url c))
-                        ])
+                   if (E.decodeUtf8With lenientDecode .
+                       B64.decodeLenient . C.pack . T.unpack)
+                        siteurl ==
+                      fromMaybe "" (w_url c)
+                     then do
+                       status ok200
+                       Web.Scotty.json
+                         (object
+                            [ "authorized" .= True
+                            , "message" .= ("Already authorized." :: String)
+                            ])
+                     else do
+                       status accepted202
+                       Web.Scotty.json
+                         (object
+                            [ "authorized" .= False
+                            , "message" .=
+                              ("ZGo shop already linked to " <>
+                               fromMaybe "" (w_url c))
+                            ])
           else do
             status accepted202
             Web.Scotty.json
@@ -667,6 +694,7 @@ routes pipe config = do
     curr <- param "currency"
     amount <- param "amount"
     sUrl <- param "siteurl"
+    orderKey <- param "orderkey"
     res <- liftAndCatchIO $ run (findWooToken (read oid))
     let c = cast' . Doc =<< res
     case c of
@@ -703,7 +731,9 @@ routes pipe config = do
                               ZGoOrder
                                 Nothing
                                 (oaddress o)
-                                ("WC-" <> oname o)
+                                (case o_id o of
+                                   Just o' -> "WC-" <> (T.pack . show $ o')
+                                   Nothing -> "")
                                 (parseTimeOrError
                                    True
                                    defaultTimeLocale
@@ -720,7 +750,8 @@ routes pipe config = do
                                     amount
                                 ]
                                 False
-                                (T.concat [T.pack sUrl, "-", ordId])
+                                (T.concat
+                                   [T.pack sUrl, "-", ordId, "-", orderKey])
                                 ""
                         newId <- liftAndCatchIO $ run (insertWooOrder newOrder)
                         status ok200
@@ -1011,8 +1042,10 @@ getZcashPrices = do
 -- | Function to update the Zcash prices in the ZGo db
 checkZcashPrices :: Pipe -> T.Text -> IO ()
 checkZcashPrices p db = do
-  q <- getZcashPrices
-  mapM_ (access p master db) (updatePrices (getResponseBody q))
+  q <- try getZcashPrices
+  case q of
+    Left e -> print (e :: HttpException)
+    Right q1 -> mapM_ (access p master db) (updatePrices (getResponseBody q1))
 
 -- | Function to search for transactions for an address
 listTxs ::
@@ -1097,20 +1130,57 @@ scanPayments config pipe = do
       case xOrder of
         Nothing -> error "Failed to retrieve order from database"
         Just xO ->
-          unless
-            (qpaid xO && qexternalInvoice xO == "" && qtotalZec xO == snd x) $ 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)
+          when
+            (not (qpaid xO) &&
+             qexternalInvoice xO /= "" && qtotalZec xO == snd x) $ 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)
+                     "WC" -> do
+                       let wOwner = fst $ head sResult ! 2
+                       wooT <-
+                         access p master dbName $ findWooToken (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)
+                             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

test/Spec.hs

@@ -304,6 +304,7 @@ main = do
                 , ("currency", Just "usd")
                 , ("amount", Just "100.0")
                 , ("date", Just "2022-12-01")
+                , ("orderkey", Just "wc_order_m7qiJ1dNrGDYE")
                 ]
             res <- httpJSON req
             getResponseStatus (res :: Response A.Value) `shouldBe` ok200