zgo-backend/src/Xero.hs

{-# LANGUAGE OverloadedStrings #-}

module Xero where

import Control.Exception
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
import Data.Time.Calendar
import Data.Time.Clock
import Database.MongoDB
import GHC.Generics
import Network.HTTP.Simple
import Network.HTTP.Types.Header
import Owner
import Web.JWT

-- | Type to represent a Xero app configuration
data Xero =
  Xero
    { x_id :: ObjectId
    , x_clientId :: T.Text
    , x_clientSecret :: T.Text
    }
  deriving (Eq, Show)

instance ToJSON Xero where
  toJSON (Xero i cI s) =
    object ["_id" .= show i, "clientId" .= cI, "clientSecret" .= s]

instance Val Xero where
  val (Xero i cI s) = Doc ["_id" =: i, "clientId" =: cI, "clientSecret" =: s]
  cast' (Doc d) = do
    i <- B.lookup "_id" d
    cI <- B.lookup "clientId" d
    s <- B.lookup "clientSecret" d
    Just (Xero i cI s)
  cast' _ = Nothing

-- | Type to represent a Xero access token
data XeroToken =
  XeroToken
    { t_id :: Maybe ObjectId
    , t_address :: T.Text
    , t_access :: T.Text
    , t_expires :: Integer
    , t_refresh :: T.Text
    , t_accdte :: UTCTime
    , t_refdte :: UTCTime
    }
  deriving (Eq, Show)

instance ToJSON XeroToken where
  toJSON (XeroToken i a t e r aD d) =
    case i of
      Just oid ->
        object
          [ "_id" .= show oid
          , "address" .= a
          , "accessToken" .= t
          , "expires" .= e
          , "refreshToken" .= r
          , "accExpires" .= aD
          , "refExpires" .= d
          ]
      Nothing ->
        object
          [ "_id" .= ("" :: String)
          , "address" .= a
          , "accessToken" .= t
          , "expires" .= e
          , "refreshToken" .= r
          , "accExpires" .= aD
          , "refExpires" .= d
          ]

instance FromJSON XeroToken where
  parseJSON =
    withObject "XeroToken" $ \obj -> do
      t <- obj .: "access_token"
      e <- obj .: "expires_in"
      r <- obj .: "refresh_token"
      pure $
        XeroToken
          Nothing
          ""
          t
          e
          r
          (UTCTime (fromGregorian 2000 1 1) (secondsToDiffTime 0))
          (UTCTime (fromGregorian 2000 1 1) (secondsToDiffTime 0))

instance Val XeroToken where
  val (XeroToken i a t e r aD d) =
    if isJust i
      then Doc
             [ "_id" =: i
             , "address" =: a
             , "accessToken" =: t
             , "expires" =: e
             , "refreshToken" =: r
             , "accExpires" =: aD
             , "refExpires" =: d
             ]
      else Doc
             [ "address" =: a
             , "accessToken" =: t
             , "expires" =: e
             , "refreshToken" =: r
             , "accExpires" =: aD
             , "refExpires" =: d
             ]
  cast' (Doc d) = do
    i <- B.lookup "_id" d
    a <- B.lookup "address" d
    t <- B.lookup "accessToken" d
    e <- B.lookup "expires" d
    r <- B.lookup "refreshToken" d
    aD <- B.lookup "accExpires" d
    d <- B.lookup "refExpires" d
    Just (XeroToken i a t e r aD d)
  cast' _ = Nothing

processToken :: XeroToken -> T.Text -> IO XeroToken
processToken t a = do
  now <- getCurrentTime
  return $
    XeroToken
      (t_id t)
      a
      (t_access t)
      (t_expires t)
      (t_refresh t)
      (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")

upsertToken :: XeroToken -> Action IO (Maybe Document)
upsertToken t = do
  let token = val t
  case token of
    Doc d -> do
      upsert (select ["address" =: t_address t] "xerotokens") d
      findOne (select ["address" =: t_address t] "xerotokens")
    _ -> return Nothing

findToken :: T.Text -> Action IO (Maybe Document)
findToken a = findOne (select ["address" =: a] "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 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
          Nothing ->
            "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 =
            addRequestHeader hContentType "application/json" $
            setRequestQueryString [("authEventId", Just (encodeUtf8 e))] $
            setRequestSecure True $
            setRequestBearerAuth (encodeUtf8 $ t_access t) $
            setRequestPort 443 $
            setRequestPath "/connections" $
            setRequestHost "api.xero.com" $
            setRequestMethod "GET" defaultRequest
      res <- httpJSON req
      let tenants = getResponseBody (res :: Response [XeroTenant])
      --print tenants
      _ <- access pipe master dbName $ setTenant (t_address t) (head tenants)
      return ()
    _ -> error "Incorrect type for authorization_event_id"

-- | Update an Owner with XeroTenant id
setTenant :: T.Text -> XeroTenant -> Action IO ()
setTenant a t =
  modify (select ["address" =: a] "owners") ["$set" =: ["crmToken" =: xt_tid t]]

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
                      invData <-
                        try
                          (evaluate $
                           getResponseBody (res :: Response XeroInvResponse)) :: IO (Either JSONException XeroInvResponse)
                      case invData of
                        Left ex -> do
                          putStrLn "Failed to parse JSON from Xero"
                          return Nothing
                        Right iData -> return $ Just (head $ xir_invs iData)
                    _ -> return Nothing