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
    , t_code :: T.Text
    }
  deriving (Eq, Show)

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

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 c) =
    if isJust i
      then Doc
             [ "_id" =: i
             , "address" =: a
             , "accessToken" =: t
             , "expires" =: e
             , "refreshToken" =: r
             , "accExpires" =: aD
             , "refExpires" =: d
             , "accCode" =: c
             ]
      else Doc
             [ "address" =: a
             , "accessToken" =: t
             , "expires" =: e
             , "refreshToken" =: r
             , "accExpires" =: aD
             , "refExpires" =: d
             , "accCode" =: c
             ]
  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
    dte <- B.lookup "refExpires" d
    c <- B.lookup "accCode" d
    Just (XeroToken i a t e r aD dte c)
  cast' _ = Nothing

processToken :: XeroToken -> T.Text -> T.Text -> IO XeroToken
processToken t a c = 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)
      c

-- |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 :: Maybe 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 .: "AmountDue"
      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")

findExpiringTokens :: UTCTime -> Action IO [Document]
findExpiringTokens now =
  rest =<<
  find (select ["refExpires" =: ["$lte" =: addUTCTime 172800 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 address oToken

refreshToken ::
     Pipe -> T.Text -> Xero -> T.Text -> T.Text -> Maybe XeroToken -> IO Bool
refreshToken pipe dbName cred code address token = do
  let pars =
        case token of
          Just x -> "grant_type=refresh_token&refresh_token=" <> t_refresh x
          Nothing ->
            "grant_type=authorization_code&code=" <>
            code <> "&redirect_uri=http://localhost:4200/xeroauth"
  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)
      let accCode = t_code <$> token
      {-let address = t_address <$> token-}
      pToken <-
        processToken
          newToken
          (maybe address t_address token)
          (fromMaybe "" accCode)
      --print pToken
      _ <- access pipe master dbName $ upsertToken pToken
      _ <- getTenantId pipe dbName pToken
      return True
    _ -> do
      print res
      return False

-- |Function to add a Xero account code to the database
addAccCode :: T.Text -> T.Text -> Action IO ()
addAccCode a c =
  modify (select ["address" =: a] "xerotokens") ["$set" =: ["accCode" =: c]]

-- |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
      if not (null tenants)
        then do
          _ <-
            access pipe master dbName $ setTenant (t_address t) (head tenants)
          return ()
        else error "Couldn't find tenant ID"
    _ -> 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
  let xToken = cast' . Doc =<< token
  case xToken of
    Nothing -> return Nothing
    Just xT -> do
      let aToken = t_access xT
      o <- access pipe master dbName $ findOwner address
      let ownerData = cast' . Doc =<< o
      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

payXeroInvoice ::
     Pipe -> T.Text -> T.Text -> T.Text -> Double -> Double -> IO ()
payXeroInvoice pipe dbName inv address amt zec = do
  token <- access pipe master dbName $ findToken address
  let aToken = t_access <$> (token >>= cast' . Doc)
  let aCode = t_code <$> (token >>= cast' . Doc)
  o <- access pipe master dbName $ findOwner address
  let tenant = ocrmToken <$> (o >>= cast' . Doc)
  today <- getCurrentTime
  if isJust aToken && isJust tenant && isJust aCode
    then do
      let req =
            setRequestBodyJSON
              (object
                 [ "Invoice" .= object ["InvoiceNumber" .= inv]
                 , "Account" .= object ["Code" .= fromMaybe "" aCode]
                 , "Date" .= utctDay today
                 , "Reference" .=
                   ("Paid in Zcash through ZGo: " ++ show zec ++ " ZEC" :: String)
                 , "Amount" .= amt
                 ]) $
            addRequestHeader "Accept" "application/json" $
            addRequestHeader "Xero-tenant-id" (encodeUtf8 $ fromMaybe "" tenant) $
            setRequestSecure True $
            setRequestBearerAuth (encodeUtf8 (fromMaybe "" aToken)) $
            setRequestPort 443 $
            setRequestPath "/api.xro/2.0/Payments" $
            setRequestHost "api.xero.com" $
            setRequestMethod "PUT" defaultRequest
      res <- httpJSON req :: IO (Response Object)
      return ()
    else error "Invalid parameters"