Merge branch 'dev' for WooCommerce integration

CHANGELOG.md

@@ -4,7 +4,21 @@ All notable changes to this project will be documented in this file.
 The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),
 and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html).
 
-## [Unreleased]
+## [1.2.0] - 2023-01-09
+
+### Added
+
+- New utility to refresh Xero tokens periodically.
+- New module for WooCommerce interaction.
+- New `/auth` endpoint to authenticate with the WooCommerce plugin and corresponding tests
+- New `/woopayment` endpoint to generate a new order from the WooCommerce plugin and corresponding tests
+- New `/wootoken` endpoint to generate a new token and query the token from the database.
+
+### Changed
+
+- Refactored code for requesting Xero tokens to make it reusable.
+- 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
 

app/Server.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Main where
+module Server where
 
 import Config
 import Control.Concurrent (forkIO)

app/TokenRefresh.hs

@@ -0,0 +1,35 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module TokenRefresh where
+
+import Config
+import Data.Time.Clock
+import Database.MongoDB
+import Xero
+
+main :: IO ()
+main = do
+  putStrLn "Reading config..."
+  now <- getCurrentTime
+  loadedConfig <- loadZGoConfig "zgo.cfg"
+  pipe <- connect $ host (c_dbHost loadedConfig)
+  let db = c_dbName loadedConfig
+  j <-
+    access
+      pipe
+      master
+      db
+      (auth (c_dbUser loadedConfig) (c_dbPassword loadedConfig))
+  if j
+    then putStrLn "Connected to MongoDB!"
+    else fail "MongoDB connection failed!"
+  credsData <- access pipe master db findXero
+  let creds = cast' . Doc =<< credsData
+  tokens <- access pipe master db (findExpiringTokens now)
+  if not (null tokens)
+    then do
+      let t = map (cast' . Doc) tokens
+      case creds of
+        Just c -> mapM_ (refreshToken pipe db c "") t
+        Nothing -> fail "No credentials"
+    else putStrLn "No tokens to refresh1"

package.yaml

@@ -1,6 +1,6 @@
 name:                zgo-backend
-version:             1.1.1
-git:                 "https://gitlab.com/pitmutt/zgo-backend"
+version:             1.2.0
+git:                 "https://git.vergara.tech/Vergara_Tech/zgo-backend"
 license:             BOSL
 author:              "Rene Vergara"
 maintainer:          "rene@vergara.network"
@@ -18,7 +18,7 @@ category:            Web
 # To avoid duplicated efforts in documentation and dealing with the
 # complications of embedding Haddock markup inside cabal files, it is
 # common to point users to the README.md file.
-description:         Please see the README on GitLab at <https://gitlab.com/pitmutt/zgo-backend#readme>
+description:         Please see the README at <https://git.vergara.tech/Vergara_Tech//zgo-backend#readme>
 
 dependencies:
 - base >= 4.7 && < 5
@@ -53,32 +53,65 @@ library:
   - scientific
   - jwt
   - containers
+  - base64-bytestring
+  - wai
+  - blake3
+  - memory
+  - ghc-prim
 
 executables:
   zgo-backend-exe:
-    main:                Main.hs
+    main:                Server.hs
     source-dirs:         app
     ghc-options:
-    - -threaded
-    - -rtsopts
-    - -with-rtsopts=-N
-    - -Wall
+            - -main-is Server
+            - -threaded
+            - -rtsopts
+            - -with-rtsopts=-N
+            - -Wall
     dependencies:
-    - zgo-backend
-    - base
-    - scotty
-    - wai-extra
-    - securemem
-    - text
-    - aeson
-    - mongoDB
-    - http-types
-    - http-conduit
-    - time
-    - bytestring
-    - configurator
-    - warp-tls
-    - warp
+            - zgo-backend
+            - base
+            - scotty
+            - wai-extra
+            - securemem
+            - text
+            - aeson
+            - mongoDB
+            - http-types
+            - http-conduit
+            - time
+            - bytestring
+            - configurator
+            - warp-tls
+            - warp
+  zgo-token-refresh:
+    main:                TokenRefresh.hs
+    source-dirs:         app
+    ghc-options:
+            - -main-is TokenRefresh
+            - -threaded
+            - -rtsopts
+            - -with-rtsopts=-N
+            - -Wall
+    dependencies:
+            - base
+            - zgo-backend
+            - base
+            - scotty
+            - wai-extra
+            - securemem
+            - text
+            - aeson
+            - mongoDB
+            - http-types
+            - http-conduit
+            - time
+            - bytestring
+            - configurator
+            - warp-tls
+            - warp
+
 
 tests:
   zgo-backend-test:

src/Order.hs

@@ -191,6 +191,13 @@ upsertOrder o = do
          else insert_ "orders" d
     _ -> return ()
 
+insertWooOrder :: ZGoOrder -> Action IO Database.MongoDB.Value
+insertWooOrder o = do
+  let order = val $ updateOrderTotals o
+  case order of
+    Doc d -> insert "orders" d
+    _ -> fail "Couldn't parse order"
+
 upsertXeroOrder :: ZGoOrder -> Action IO ()
 upsertXeroOrder o = do
   let order = val $ updateOrderTotals o

src/WooCommerce.hs

@@ -0,0 +1,100 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module WooCommerce where
+
+import qualified BLAKE3 as BLK
+import Data.Aeson
+import qualified Data.Bson as B
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base64 as B64
+import qualified Data.ByteString.Char8 as C
+import Data.Maybe
+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
+import Owner
+
+-- | Type to represent the WooCommerce token
+data WooToken =
+  WooToken
+    { w_id :: Maybe ObjectId
+    , w_owner :: ObjectId
+    , w_token :: T.Text
+    , w_url :: Maybe T.Text
+    }
+  deriving (Eq, Show)
+
+instance Val WooToken where
+  val (WooToken i o t u) =
+    if isJust i
+      then Doc ["_id" =: i, "owner" =: o, "token" =: t, "url" =: u]
+      else Doc ["owner" =: o, "token" =: t, "url" =: u]
+  cast' (Doc d) = do
+    i <- B.lookup "_id" d
+    o <- B.lookup "owner" d
+    t <- B.lookup "token" d
+    u <- B.lookup "url" d
+    Just
+      (WooToken
+         i
+         o
+         t
+         (E.decodeUtf8With lenientDecode . B64.decodeLenient . C.pack <$> u))
+  cast' _ = Nothing
+
+-- Database actions
+findWooToken :: ObjectId -> Action IO (Maybe Document)
+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"
+
+generateWooToken :: Owner -> Action IO ()
+generateWooToken o =
+  case o_id o of
+    Just ownerid -> do
+      let tokenHash =
+            BLK.hash
+              [ BA.pack . BS.unpack . C.pack . T.unpack $ oname o <> oaddress o :: BA.Bytes
+              ]
+      let wooToken =
+            val $
+            WooToken
+              Nothing
+              ownerid
+              (T.pack . show $ (tokenHash :: BLK.Digest BLK.DEFAULT_DIGEST_LEN))
+              Nothing
+      case wooToken of
+        Doc wT -> insert_ "wootokens" wT
+        _ -> error "Couldn't create the WooCommerce token"
+    Nothing -> error "Bad owner id"

src/Xero.hs

@@ -280,17 +280,24 @@ upsertToken t = do
 findToken :: T.Text -> Action IO (Maybe Document)
 findToken a = findOne (select ["address" =: a] "xerotokens")
 
+findExpiringTokens :: UTCTime -> Action IO [Document]
+findExpiringTokens now =
+  rest =<<
+  find
+    (select ["refExpires" =: ["$lte" =: addUTCTime 1728000 now]] "xerotokens")
+
 -- | Function to request accesstoken
 requestXeroToken :: Pipe -> T.Text -> Xero -> T.Text -> T.Text -> IO Bool
 requestXeroToken pipe dbName cred code address = do
   token <- access pipe master dbName $ findToken address
+  let oToken = token >>= cast' . Doc
+  refreshToken pipe dbName cred code oToken
+
+refreshToken :: Pipe -> T.Text -> Xero -> T.Text -> Maybe XeroToken -> IO Bool
+refreshToken pipe dbName cred code token = do
   let pars =
         case token of
-          Just xT -> do
-            let xToken = cast' (Doc xT) :: Maybe XeroToken
-            case xToken of
-              Nothing -> error "Failed to parse XeroToken BSON"
-              Just x -> "grant_type=refresh_token&refresh_token=" <> t_refresh x
+          Just x -> "grant_type=refresh_token&refresh_token=" <> t_refresh x
           Nothing ->
             "grant_type=authorization_code&code=" <>
             code <> "&redirect_uri=http://localhost:4200/xeroauth"
@@ -309,8 +316,10 @@ requestXeroToken pipe dbName cred code address = do
   case rCode of
     200 -> do
       let newToken = getResponseBody (res :: Response XeroToken)
-      let accCode = t_code <$> (token >>= cast' . Doc)
-      pToken <- processToken newToken address (fromMaybe "" accCode)
+      let accCode = t_code <$> token
+      let address = t_address <$> token
+      pToken <-
+        processToken newToken (fromMaybe "" address) (fromMaybe "" accCode)
       --print pToken
       _ <- access pipe master dbName $ upsertToken pToken
       _ <- getTenantId pipe dbName pToken
@@ -429,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,12 +8,15 @@ 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
 import Data.Array
 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.Char
 import qualified Data.HashMap.Strict as HM
 import Data.HexString
@@ -26,6 +29,7 @@ import Data.Text.Encoding.Error (lenientDecode)
 import qualified Data.Text.Lazy as L
 import Data.Time.Clock
 import Data.Time.Clock.POSIX
+import Data.Time.Format
 import Data.Typeable
 import qualified Data.Vector as V
 import Data.Vector.Internal.Check (doChecks)
@@ -35,8 +39,8 @@ 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
 import Network.Wai.Middleware.HttpAuth
 import Numeric
@@ -52,6 +56,7 @@ import Text.Regex
 import Text.Regex.Base
 import User
 import Web.Scotty
+import WooCommerce
 import Xero
 import ZGoTx
 
@@ -487,6 +492,16 @@ upsertPayment pipe dbName p = do
           upsert (select ["txid" =: txid p] "payments") d
         _ -> return ()
 
+authSettings :: AuthSettings
+authSettings = "ZGo Backend" {authIsProtected = needsAuth}
+
+needsAuth :: Network.Wai.Request -> IO Bool
+needsAuth req =
+  return $
+  case pathInfo req of
+    "api":_ -> True
+    _ -> False
+
 -- | Main API routes
 routes :: Pipe -> Config -> ScottyM ()
 routes pipe config = do
@@ -507,7 +522,7 @@ routes pipe config = do
   middleware $
     basicAuth
       (\u p -> return $ u == "user" && secureMemFromByteString p == passkey)
-      "ZGo Backend"
+      authSettings
   --Get list of countries for UI
   get "/api/countries" $ do
     countries <- liftAndCatchIO $ run listCountries
@@ -604,6 +619,161 @@ 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
+             ])
+  post "/api/wootoken" $ do
+    oid <- param "ownerid"
+    res <- liftAndCatchIO $ run (findOwnerById oid)
+    let o1 = cast' . Doc =<< res
+    case o1 of
+      Nothing -> status noContent204
+      Just o -> do
+        liftAndCatchIO $ run (generateWooToken o)
+        status accepted202
+  -- Authenticate the WooCommerce plugin
+  get "/auth" $ do
+    oid <- param "ownerid"
+    t <- param "token"
+    siteurl <- param "siteurl"
+    res <- liftAndCatchIO $ run (findWooToken (read oid))
+    let c1 = cast' . Doc =<< res
+    case c1 of
+      Nothing -> do
+        status accepted202
+        Web.Scotty.json
+          (object
+             ["authorized" .= False, "message" .= ("Owner not found" :: String)])
+      Just c ->
+        if t == w_token c
+          then if isNothing (w_url c)
+                 then do
+                   liftAndCatchIO $ run (addUrl c siteurl)
+                   status ok200
+                   Web.Scotty.json
+                     (object
+                        [ "authorized" .= True
+                        , "message" .= ("Authorized!" :: String)
+                        ])
+                 else do
+                   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
+              (object
+                 [ "authorized" .= False
+                 , "message" .= ("Token mismatch" :: String)
+                 ])
+  get "/woopayment" $ do
+    oid <- param "ownerid"
+    t <- param "token"
+    ordId <- param "order_id"
+    date <- param "date"
+    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
+      Nothing -> do
+        status accepted202
+        Web.Scotty.json
+          (object ["message" .= ("Plugin not setup in ZGo" :: String)])
+      Just x ->
+        if t == w_token x &&
+           (E.decodeUtf8With lenientDecode . B64.decodeLenient . C.pack) sUrl ==
+           fromMaybe "" (w_url x)
+          then do
+            zecPriceDb <- liftAndCatchIO (run (findPrice curr))
+            let zecPrice = parseZGoPrice =<< zecPriceDb
+            case zecPrice of
+              Nothing -> do
+                status accepted202
+                Web.Scotty.json
+                  (object ["message" .= ("Currency not supported" :: String)])
+              Just zP -> do
+                ownerDb <-
+                  liftAndCatchIO $
+                  run (findOwnerById (T.pack . show $ w_owner x))
+                let owner = cast' . Doc =<< ownerDb
+                case owner of
+                  Nothing -> do
+                    status accepted202
+                    Web.Scotty.json
+                      (object ["message" .= ("Owner not found" :: String)])
+                  Just o ->
+                    if opaid o
+                      then do
+                        let newOrder =
+                              ZGoOrder
+                                Nothing
+                                (oaddress o)
+                                (case o_id o of
+                                   Just o' -> "WC-" <> (T.pack . show $ o')
+                                   Nothing -> "")
+                                (parseTimeOrError
+                                   True
+                                   defaultTimeLocale
+                                   "%Y-%0m-%0d"
+                                   date)
+                                True
+                                (T.pack curr)
+                                (price zP)
+                                0.0
+                                0.0
+                                [ LineItem
+                                    1.0
+                                    (oname o <> " order " <> ordId)
+                                    amount
+                                ]
+                                False
+                                (T.concat
+                                   [T.pack sUrl, "-", ordId, "-", orderKey])
+                                ""
+                        newId <- liftAndCatchIO $ run (insertWooOrder newOrder)
+                        status ok200
+                        Web.Scotty.json (object ["order" .= show newId])
+                      else do
+                        status accepted202
+                        Web.Scotty.json
+                          (object
+                             ["message" .= ("ZGo shop not paid for" :: String)])
+          else do
+            status accepted202
+            Web.Scotty.json
+              (object ["message" .= ("Incorrect plugin config" :: String)])
   --Get user associated with session
   get "/api/user" $ do
     sess <- param "session"
@@ -881,8 +1051,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 ::
@@ -967,20 +1139,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

stack.yaml

@@ -17,8 +17,8 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver:
-  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/4.yaml
+resolver: lts-19.33
+  #url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/4.yaml
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.
@@ -44,6 +44,7 @@ packages:
 extra-deps:
   - git: https://github.com/reach-sh/haskell-hexstring.git
     commit: 085c16fb21b9f856a435a3faab980e7e0b319341
+  - blake3-0.2@sha256:d1146b9a51ccfbb0532780778b6d016a614e3d44c05d8c1923dde9a8be869045,2448
 # Override default flag values for local packages and extra-deps
 # flags: {}
 

stack.yaml.lock

@@ -5,20 +5,26 @@
 
 packages:
 - completed:
+    commit: 085c16fb21b9f856a435a3faab980e7e0b319341
+    git: https://github.com/reach-sh/haskell-hexstring.git
     name: hexstring
-    version: 0.11.1
-    git: https://github.com/reach-sh/haskell-hexstring.git
     pantry-tree:
-      size: 687
       sha256: 9ecf67856f59dfb382b283eceb42e4fc1865935d1a7e59111556ed381c6a2ffd
-    commit: 085c16fb21b9f856a435a3faab980e7e0b319341
+      size: 687
+    version: 0.11.1
   original:
-    git: https://github.com/reach-sh/haskell-hexstring.git
     commit: 085c16fb21b9f856a435a3faab980e7e0b319341
+    git: https://github.com/reach-sh/haskell-hexstring.git
+- completed:
+    hackage: blake3-0.2@sha256:d1146b9a51ccfbb0532780778b6d016a614e3d44c05d8c1923dde9a8be869045,2448
+    pantry-tree:
+      sha256: 0264ef3e7919e7b0d668c4153f6ce0d88e6965626b52d9dfd2cafd70309501d3
+      size: 1433
+  original:
+    hackage: blake3-0.2@sha256:d1146b9a51ccfbb0532780778b6d016a614e3d44c05d8c1923dde9a8be869045,2448
 snapshots:
 - completed:
-    size: 618683
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/4.yaml
-    sha256: d4ee004c46ba878d2f304f5d748d493057be579192a8d148527f3ba55c9df57f
-  original:
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/4.yaml
+    sha256: 6d1532d40621957a25bad5195bfca7938e8a06d923c91bc52aa0f3c41181f2d4
+    size: 619204
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/33.yaml
+  original: lts-19.33

test/Spec.hs

@@ -33,6 +33,7 @@ import Test.QuickCheck.Gen
 import Test.QuickCheck.Monadic
 import User
 import Web.Scotty
+import WooCommerce
 import Xero
 import ZGoBackend
 import ZGoTx
@@ -156,7 +157,7 @@ main = do
             res <- httpJSON req
             getResponseStatus (res :: Response A.Value) `shouldBe` ok200
         describe "blockheight endpoint" $ do
-          xit "returns a block number" $ do
+          it "returns a block number" $ do
             req <- testGet "/api/blockheight" []
             res <- httpJSON req
             height (getResponseBody (res :: Response Block)) `shouldSatisfy` \x ->
@@ -250,6 +251,69 @@ main = do
             req <- testDelete "/api/item/" "627d7ba92b05a76be3000003"
             res <- httpLBS req
             getResponseStatus res `shouldBe` ok200
+        describe "WooCommerce endpoints" $ do
+          it "generate token" $ do
+            req <-
+              testPost
+                "/api/wootoken"
+                [("ownerid", Just "627ad3492b05a76be5000001")]
+            res <- httpLBS req
+            getResponseStatus res `shouldBe` accepted202
+          it "authenticate with incorrect owner" $ do
+            req <-
+              testPublicGet
+                "/auth"
+                [ ("ownerid", Just "62cca13f5530331e2a900001")
+                , ("token", Just "89bd9d8d69a674e0f467cc8796ed151a")
+                , ("siteurl", Just "aHR0cHM6Ly93d3cudGVjcHJvdmFsLmNvbS8")
+                ]
+            res <- httpJSON req
+            getResponseStatus (res :: Response A.Value) `shouldBe` accepted202
+          it "authenticate with incorrect token" $ do
+            req <-
+              testPublicGet
+                "/auth"
+                [ ("ownerid", Just "627ad3492b05a76be3000001")
+                , ("token", Just "89bd9d8d69a674e0f467cc8796000000")
+                , ("siteurl", Just "aHR0cHM6Ly93d3cudGVjcHJvdmFsLmNvbS8")
+                ]
+            res <- httpJSON req
+            getResponseStatus (res :: Response A.Value) `shouldBe` accepted202
+          it "authenticate with correct token" $ do
+            req <-
+              testPublicGet
+                "/auth"
+                [ ("ownerid", Just "627ad3492b05a76be3000001")
+                , ("token", Just "89bd9d8d69a674e0f467cc8796ed151a")
+                , ("siteurl", Just "aHR0cHM6Ly93d3cudGVjcHJvdmFsLmNvbS8")
+                ]
+            res <- httpJSON req
+            getResponseStatus (res :: Response A.Value) `shouldBe` ok200
+          it "authenticate with correct token on existing shop" $ do
+            req <-
+              testPublicGet
+                "/auth"
+                [ ("ownerid", Just "627ad3492b05a76be3000001")
+                , ("token", Just "89bd9d8d69a674e0f467cc8796ed151a")
+                , ("siteurl", Just "aHR0cHM6Ly93d3cuZ29vZ2xlLmNvbS8")
+                ]
+            res <- httpJSON req
+            getResponseStatus (res :: Response A.Value) `shouldBe` accepted202
+          it "request order creation" $ do
+            req <-
+              testPublicGet
+                "/woopayment"
+                [ ("ownerid", Just "627ad3492b05a76be3000001")
+                , ("token", Just "89bd9d8d69a674e0f467cc8796ed151a")
+                , ("siteurl", Just "aHR0cHM6Ly93d3cudGVjcHJvdmFsLmNvbS8")
+                , ("order_id", Just "1234")
+                , ("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
     around handleDb $
       describe "Database actions" $ do
         describe "authentication" $ do
@@ -304,7 +368,7 @@ main = do
           it "deleted" $ \p -> do
             t <- access p master "test" $ findOne (select [] "users")
             let s = parseUserBson =<< t
-            let userId = maybe Nothing u_id s
+            let userId = u_id =<< s
             let idString = maybe "" show userId
             _ <- access p master "test" $ deleteUser idString
             q <-
@@ -332,6 +396,7 @@ main = do
             let ordTest = val myOrder
             case ordTest of
               Doc oT -> access p master "test" (insert_ "orders" oT)
+              _ -> fail "Couldn't save Order in DB"
             _ <-
               access p master "test" $
               markOrderPaid ("627ab3ea2b05a76be3000001", 0)
@@ -496,6 +561,15 @@ testGet endpoint body = do
         setRequestMethod "GET" $ setRequestPath endpoint defaultRequest
   return testRequest
 
+testPublicGet ::
+     B.ByteString -> [(B.ByteString, Maybe B.ByteString)] -> IO Request
+testPublicGet endpoint body = do
+  let testRequest =
+        setRequestQueryString body $
+        setRequestPort 3000 $
+        setRequestMethod "GET" $ setRequestPath endpoint defaultRequest
+  return testRequest
+
 testPost :: B.ByteString -> [(B.ByteString, Maybe B.ByteString)] -> IO Request
 testPost endpoint body = do
   let user = "user"
@@ -576,6 +650,8 @@ startAPI config = do
   c <- access pipe master "zgo" (auth "zgo" "zcashrules")
   let appRoutes = routes pipe config
   _ <- forkIO (scotty 3000 appRoutes)
+  _ <-
+    access pipe master "test" (Database.MongoDB.delete (select [] "wootokens"))
   let myUser =
         User
           (Just (read "6272a90f2b05a74cf1000001" :: ObjectId))
@@ -618,8 +694,35 @@ startAPI config = do
           ""
           "bubbarocks.io"
           "United States"
+          True
           False
           False
+          (UTCTime (fromGregorian 2022 4 16) (secondsToDiffTime 0))
+          False
+          ""
+          ""
+  let myOwner1 =
+        Owner
+          (Just (read "627ad3492b05a76be5000001"))
+          "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
+          "Test shop"
+          "usd"
+          False
+          0
+          False
+          0
+          "Bubba"
+          "Gibou"
+          "bubba@zgo.cash"
+          "1 Main St"
+          "Mpls"
+          "Minnesota"
+          "55401"
+          ""
+          "bubbarocks.io"
+          "United States"
+          True
+          False
           False
           (UTCTime (fromGregorian 2022 4 16) (secondsToDiffTime 0))
           False
@@ -629,6 +732,7 @@ startAPI config = do
   let o = val myOwner
   case o of
     Doc d -> access pipe master "test" (insert_ "owners" d)
+    _ -> fail "Couldn't save Owner in DB"
   _ <- access pipe master "test" (Database.MongoDB.delete (select [] "orders"))
   myTs <- liftIO getCurrentTime
   let myOrder =
@@ -649,6 +753,7 @@ startAPI config = do
   let ordTest = val myOrder
   case ordTest of
     Doc oT -> access pipe master "test" (insert_ "orders" oT)
+    _ -> fail "Couldn't save Order in DB"
   let myItem1 =
         Item
           (Just (read "627d7ba92b05a76be3000003"))
@@ -659,6 +764,17 @@ startAPI config = do
   let itemTest = val myItem1
   case itemTest of
     Doc iT -> access pipe master "test" (insert_ "items" iT)
+    _ -> fail "Couldn't save test Item in DB"
+  let myWooToken =
+        WooToken
+          Nothing
+          (read "627ad3492b05a76be3000001")
+          "89bd9d8d69a674e0f467cc8796ed151a"
+          Nothing
+  let wooTest = val myWooToken
+  case wooTest of
+    Doc wT -> access pipe master "test" (insert_ "wootokens" wT)
+    _ -> fail "Couldn't save test WooToken in DB"
   threadDelay 1000000
   putStrLn "Test server is up!"
 

zgo-backend.cabal

@@ -1,11 +1,11 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.34.4.
+-- This file has been generated from package.yaml by hpack version 0.35.0.
 --
 -- see: https://github.com/sol/hpack
 
 name:           zgo-backend
-version:        1.1.0
+version:        1.1.1
 synopsis:       Haskell Back-end for the ZGo point-of-sale application
 description:    Please see the README on GitLab at <https://gitlab.com/pitmutt/zgo-backend#readme>
 category:       Web
@@ -32,6 +32,7 @@ library
       Owner
       Payment
       User
+      WooCommerce
       Xero
       ZGoBackend
       ZGoTx
@@ -44,14 +45,18 @@ library
     , aeson
     , array
     , base >=4.7 && <5
+    , base64-bytestring
+    , blake3
     , bson
     , bytestring
     , configurator
     , containers
+    , ghc-prim
     , hexstring
     , http-conduit
     , http-types
     , jwt
+    , memory
     , mongoDB
     , quickcheck-instances
     , random
@@ -64,18 +69,46 @@ library
     , time
     , unordered-containers
     , vector
+    , wai
     , wai-cors
     , wai-extra
     , warp-tls
   default-language: Haskell2010
 
 executable zgo-backend-exe
-  main-is: Main.hs
+  main-is: Server.hs
   other-modules:
+      TokenRefresh
       Paths_zgo_backend
   hs-source-dirs:
       app
-  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall
+  ghc-options: -main-is Server -threaded -rtsopts -with-rtsopts=-N -Wall
+  build-depends:
+      aeson
+    , base
+    , bytestring
+    , configurator
+    , http-conduit
+    , http-types
+    , mongoDB
+    , scotty
+    , securemem
+    , text
+    , time
+    , wai-extra
+    , warp
+    , warp-tls
+    , zgo-backend
+  default-language: Haskell2010
+
+executable zgo-token-refresh
+  main-is: TokenRefresh.hs
+  other-modules:
+      Server
+      Paths_zgo_backend
+  hs-source-dirs:
+      app
+  ghc-options: -main-is TokenRefresh -threaded -rtsopts -with-rtsopts=-N -Wall
   build-depends:
       aeson
     , base