Implement endpoints for Xero orders

package.yaml

@@ -51,6 +51,8 @@ library:
   - hexstring
   - configurator
   - scientific
+  - jwt
+  - containers
 
 executables:
   zgo-backend-exe:

src/Order.hs

@@ -219,6 +219,9 @@ updateOrderTotals o =
 findOrder :: T.Text -> Action IO (Maybe Document)
 findOrder s = findOne (select ["session" =: s, "closed" =: False] "orders")
 
+findXeroOrder :: T.Text -> T.Text -> T.Text -> Action IO (Maybe Document)
+findXeroOrder a i s = findOne (select ["address" =: a, "externalInvoice" =: i, "shortCode" =: s] "orders")
+
 findOrderById :: String -> Action IO (Maybe Document)
 findOrderById i = findOne (select ["_id" =: (read i :: B.ObjectId)] "orders")
 

src/Xero.hs

@@ -6,6 +6,7 @@ import Control.Monad.IO.Class
 import Data.Aeson
 import qualified Data.Bson as B
 import qualified Data.ByteString.Lazy as BL
+import qualified Data.Map.Strict as M
 import Data.Maybe
 import qualified Data.Text as T
 import Data.Text.Encoding
@@ -14,7 +15,10 @@ import Data.Time.Clock
 import Database.MongoDB
 import GHC.Generics
 import Network.HTTP.Simple
+import Network.HTTP.Simple (getResponseStatus)
 import Network.HTTP.Types.Header
+import Owner
+import Web.JWT
 
 -- | Type to represent a Xero app configuration
 data Xero =
@@ -135,6 +139,123 @@ processToken t a = do
       (addUTCTime (fromIntegral $ t_expires t) now)
       (addUTCTime 5184000 now)
 
+-- |Type to represent a Xero tenant
+data XeroTenant =
+  XeroTenant
+    { xt_id :: T.Text
+    , xt_aei :: T.Text
+    , xt_tid :: T.Text
+    , xt_type :: T.Text
+    , xt_name :: T.Text
+    --, xt_created :: !UTCTime
+    --, xt_updated :: !UTCTime
+    }
+  deriving (Show, Eq)
+
+instance FromJSON XeroTenant where
+  parseJSON =
+    withObject "XeroTenant" $ \obj -> do
+      i <- obj .: "id"
+      aei <- obj .: "authEventId"
+      tI <- obj .: "tenantId"
+      tT <- obj .: "tenantType"
+      tN <- obj .: "tenantName"
+      --c <- obj .: "createdDateUtc"
+      --u <- obj .: "updatedDateUtc"
+      pure $ XeroTenant i aei tI tT tN
+
+data XeroInvoice =
+  XeroInvoice
+    { xi_id :: Maybe ObjectId
+    , xi_eid :: T.Text
+    , xi_type :: T.Text
+    , xi_number :: T.Text
+    , xi_contact :: T.Text
+    , xi_currency :: T.Text
+    , xi_currRate :: Double
+    , xi_total :: Double
+    , xi_status :: T.Text
+    , xi_date :: T.Text
+    , xi_shortcode :: T.Text
+    , xi_loadDate :: UTCTime
+    }
+  deriving (Show, Eq)
+
+instance FromJSON XeroInvoice where
+  parseJSON =
+    withObject "XeroInvoice" $ \obj -> do
+      i <- obj .:? "_id"
+      eId <- obj .: "InvoiceID"
+      t <- obj .: "Type"
+      n <- obj .: "InvoiceNumber"
+      c <- obj .: "Contact"
+      cN <- c .: "Name"
+      cu <- obj .: "CurrencyCode"
+      cR <- obj .: "CurrencyRate"
+      total <- obj .: "Total"
+      status <- obj .: "Status"
+      d <- obj .: "Date"
+      pure $
+        XeroInvoice
+          (read =<< i)
+          eId
+          t
+          n
+          cN
+          cu
+          cR
+          total
+          status
+          d
+          ""
+          (UTCTime (fromGregorian 2000 1 1) (secondsToDiffTime 0))
+
+instance ToJSON XeroInvoice where
+  toJSON (XeroInvoice i eId t n cN cu cR total status d sC pD) =
+    case i of
+      Just oid ->
+        object
+          [ "_id" .= show oid
+          , "inv_Type" .= t
+          , "inv_Id" .= eId
+          , "inv_No" .= n
+          , "inv_Contact" .= cN
+          , "inv_Currency" .= cu
+          , "inv_CurrencyRate" .= cR
+          , "inv_Total" .= total
+          , "inv_Status" .= status
+          , "inv_Date" .= d
+          , "inv_shortCode" .= sC
+          , "inv_ProcDate" .= pD
+          ]
+      Nothing ->
+        object
+          [ "_id" .= ("" :: String)
+          , "inv_Type" .= t
+          , "inv_Id" .= eId
+          , "inv_No" .= n
+          , "inv_Contact" .= cN
+          , "inv_Currency" .= cu
+          , "inv_CurrencyRate" .= cR
+          , "inv_Total" .= total
+          , "inv_Status" .= status
+          , "inv_Date" .= d
+          , "inv_shortCode" .= sC
+          , "inv_ProcDate" .= pD
+          ]
+
+newtype XeroInvResponse =
+  XeroInvResponse
+    { xir_invs :: [XeroInvoice]
+    }
+  deriving (Show, Eq)
+
+instance FromJSON XeroInvResponse where
+  parseJSON =
+    withObject "XeroInvResponse" $ \obj -> do
+      invs <- obj .: "Invoices"
+      pure $ XeroInvResponse invs
+
 -- Database actions
 findXero :: Action IO (Maybe Document)
 findXero = findOne (select [] "xero")
@@ -152,44 +273,115 @@ findToken :: T.Text -> Action IO (Maybe Document)
 findToken a = findOne (select ["address" =: a] "xerotokens")
 
 -- | Function to request accesstoken
-requestXeroToken ::
+requestXeroToken :: Pipe -> T.Text -> Xero -> T.Text -> T.Text -> IO Bool
-     (Action IO (Maybe Document) -> IO (Maybe Document))
+requestXeroToken pipe dbName cred code address = do
-  -> Xero
+  token <- access pipe master dbName $ findToken address
-  -> T.Text
+  let pars =
-  -> T.Text
+        case token of
-  -> IO Bool
+          Just xT -> do
-requestXeroToken f cred code address = do
+            let xToken = cast' (Doc xT) :: Maybe XeroToken
-  token <- f $ findToken address
+            case xToken of
-  case token of
+              Nothing -> error "Failed to parse XeroToken BSON"
-    Just xT -> do
+              Just x -> "grant_type=refresh_token&refresh_token=" <> t_refresh x
-      let xToken = cast' (Doc xT) :: Maybe XeroToken
+          Nothing ->
-      case xToken of
-        Nothing -> return False
-        Just x -> return True
-    Nothing -> do
-      let pars =
             "grant_type=authorization_code&code=" <>
             code <> "&redirect_uri=http://localhost:4200/test"
+  let req =
+        setRequestBodyLBS (BL.fromStrict (encodeUtf8 pars)) $
+        addRequestHeader hContentType "application/x-www-form-urlencoded" $
+        setRequestSecure True $
+        setRequestBasicAuth
+          (encodeUtf8 $ x_clientId cred)
+          (encodeUtf8 $ x_clientSecret cred) $
+        setRequestHost "identity.xero.com" $
+        setRequestPort 443 $
+        setRequestMethod "POST" $ setRequestPath "/connect/token" defaultRequest
+  res <- httpJSON req
+  let rCode = getResponseStatusCode (res :: Response XeroToken)
+  case rCode of
+    200 -> do
+      let newToken = getResponseBody (res :: Response XeroToken)
+      pToken <- processToken newToken address
+      --print pToken
+      _ <- access pipe master dbName $ upsertToken pToken
+      _ <- getTenantId pipe dbName pToken
+      return True
+    _ -> do
+      print res
+      return False
+
+-- |Helper function to obtain the authentication event ID
+extractEventId :: T.Text -> Maybe Data.Aeson.Value
+extractEventId t = do
+  j <- Web.JWT.decode t
+  (M.lookup "authentication_event_id" .
+   unClaimsMap . unregisteredClaims . claims)
+    j
+
+getTenantId :: Pipe -> T.Text -> XeroToken -> IO ()
+getTenantId pipe dbName t = do
+  let eid = extractEventId $ t_access t
+  --print eid
+  case eid of
+    Nothing -> error "Failed to decode JWT"
+    Just (Data.Aeson.String e) -> do
+      print e
       let req =
-            setRequestBodyLBS (BL.fromStrict (encodeUtf8 pars)) $
+            addRequestHeader hContentType "application/json" $
-            addRequestHeader hContentType "application/x-www-form-urlencoded" $
+            setRequestQueryString [("authEventId", Just (encodeUtf8 e))] $
             setRequestSecure True $
-            setRequestBasicAuth
+            setRequestBearerAuth (encodeUtf8 $ t_access t) $
-              (encodeUtf8 $ x_clientId cred)
-              (encodeUtf8 $ x_clientSecret cred) $
-            setRequestHost "identity.xero.com" $
             setRequestPort 443 $
-            setRequestMethod "POST" $
+            setRequestPath "/connections" $
-            setRequestPath "/connect/token" defaultRequest
+            setRequestHost "api.xero.com" $
+            setRequestMethod "GET" defaultRequest
       res <- httpJSON req
-      let rCode = getResponseStatusCode (res :: Response XeroToken)
+      let tenants = getResponseBody (res :: Response [XeroTenant])
-      case rCode of
+      --print tenants
-        200 -> do
+      _ <- access pipe master dbName $ setTenant (t_address t) (head tenants)
-          let newToken = getResponseBody (res :: Response XeroToken)
+      return ()
-          pToken <- processToken newToken address
+    _ -> error "Incorrect type for authorization_event_id"
-          print pToken
+
-          _ <- f $ upsertToken pToken
+-- | Update an Owner with XeroTenant id
-          return True
+setTenant :: T.Text -> XeroTenant -> Action IO ()
-        _ -> do
+setTenant a t =
-          print res
+  modify (select ["address" =: a] "owners") ["$set" =: ["crmToken" =: xt_tid t]]
-          return False
+
+getXeroInvoice :: Pipe -> T.Text -> T.Text -> T.Text -> IO (Maybe XeroInvoice)
+getXeroInvoice pipe dbName inv address = do
+  token <- access pipe master dbName $ findToken address
+  case token of
+    Nothing -> return Nothing
+    Just t -> do
+      let xToken = cast' (Doc t)
+      case xToken of
+        Nothing -> return Nothing
+        Just xT -> do
+          let aToken = t_access xT
+          o <- access pipe master dbName $ findOwner address
+          case o of
+            Nothing -> return Nothing
+            Just ow -> do
+              let ownerData = cast' (Doc ow)
+              case ownerData of
+                Nothing -> return Nothing
+                Just oD -> do
+                  let tenant = ocrmToken oD
+                  let req =
+                        addRequestHeader "Accept" "application/json" $
+                        addRequestHeader "Xero-tenant-id" (encodeUtf8 tenant) $
+                        setRequestSecure True $
+                        setRequestBearerAuth (encodeUtf8 aToken) $
+                        setRequestPort 443 $
+                        setRequestPath
+                          ("/api.xro/2.0/Invoices/" <> encodeUtf8 inv) $
+                        setRequestHost "api.xero.com" $
+                        setRequestMethod "GET" defaultRequest
+                  res <- httpJSON req
+                  let sCode = getResponseStatusCode res
+                  case sCode of
+                    200 -> do
+                      let invData =
+                            getResponseBody (res :: Response XeroInvResponse)
+                      return $ Just (head $ xir_invs invData)
+                    _ -> return Nothing

src/ZGoBackend.hs

@@ -28,12 +28,14 @@ import Data.Time.Clock
 import Data.Time.Clock.POSIX
 import Data.Typeable
 import qualified Data.Vector as V
+import Data.Vector.Internal.Check (doChecks)
 import Data.Word
 import Database.MongoDB
 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.Middleware.Cors
 import Network.Wai.Middleware.HttpAuth
@@ -509,15 +511,39 @@ routes pipe config = do
           Nothing -> status noContent204
           Just c -> do
             res <-
-              liftIO $
+              liftIO $ requestXeroToken pipe (c_dbName config) c code address
-              requestXeroToken
-                (run :: Action IO (Maybe Document) -> IO (Maybe Document))
-                c
-                code
-                address
             if res
               then status ok200
               else status noContent204
+  get "/api/invdata" $ do
+    inv <- param "inv"
+    oAddress <- param "address"
+    xeroConfig <- liftIO $ run findXero
+    case xeroConfig of
+      Nothing -> do
+        status noContent204
+        text "Xero App credentials not found"
+      Just x -> do
+        let xConfig = cast' (Doc x)
+        case xConfig of
+          Nothing -> do
+            status noContent204
+            text "Xero App credentials corrupted"
+          Just c -> do
+            res <-
+              liftIO $ requestXeroToken pipe (c_dbName config) c "none" oAddress
+            if res
+              then do
+                resInv <-
+                  liftIO $ getXeroInvoice pipe (c_dbName config) inv oAddress
+                case resInv of
+                  Nothing -> do
+                    status noContent204
+                    text "Xero invoice not found"
+                  Just xI -> do
+                    status ok200
+                    Web.Scotty.json (object ["invdata" .= toJSON xI])
+              else status noContent204
   post "/api/xerotoken" $ do
     o <- jsonData
     let q = payload (o :: Payload XeroToken)
@@ -743,7 +769,28 @@ routes pipe config = do
                  [ "message" .= ("Order found!" :: String)
                  , "order" .= toJSON (pOrder :: ZGoOrder)
                  ])
-    --Upsert order
+  --Upsert xero order
+  post "/api/orderx" $ do
+    newOrder <- jsonData
+    let q = payload (newOrder :: Payload ZGoOrder)
+    _ <- liftIO $ run (upsertOrder q)
+    myOrder <-
+      liftIO $
+      run (findXeroOrder (qaddress q) (qexternalInvoice q) (qshortCode q))
+    case myOrder of
+      Nothing -> status noContent204
+      Just o -> do
+        let o' = cast' (Doc o)
+        case o' of
+          Nothing -> status internalServerError500
+          Just pOrder -> do
+            status created201
+            Web.Scotty.json
+              (object
+                 [ "message" .= ("Order found!" :: String)
+                 , "order" .= toJSON (pOrder :: ZGoOrder)
+                 ])
+  -- Upsert order
   post "/api/order" $ do
     newOrder <- jsonData
     let q = payload (newOrder :: Payload ZGoOrder)

zgo-backend.cabal

@@ -47,9 +47,11 @@ library
     , bson
     , bytestring
     , configurator
+    , containers
     , hexstring
     , http-conduit
     , http-types
+    , jwt
     , mongoDB
     , quickcheck-instances
     , random