zgo-backend/src/Xero.hs

434 lines
13 KiB
Haskell
Raw Normal View History

2022-08-10 15:17:47 +00:00
{-# LANGUAGE OverloadedStrings #-}
module Xero where
2022-08-23 14:55:04 +00:00
import Control.Exception
2022-08-18 19:21:32 +00:00
import Control.Monad.IO.Class
2022-08-10 15:17:47 +00:00
import Data.Aeson
import qualified Data.Bson as B
2022-08-18 19:21:32 +00:00
import qualified Data.ByteString.Lazy as BL
2022-08-20 13:09:46 +00:00
import qualified Data.Map.Strict as M
2022-08-11 22:30:24 +00:00
import Data.Maybe
2022-08-10 15:17:47 +00:00
import qualified Data.Text as T
2022-08-18 19:21:32 +00:00
import Data.Text.Encoding
import Data.Time.Calendar
2022-08-11 22:30:24 +00:00
import Data.Time.Clock
2022-08-10 15:17:47 +00:00
import Database.MongoDB
import GHC.Generics
2022-08-18 19:21:32 +00:00
import Network.HTTP.Simple
import Network.HTTP.Types.Header
2022-08-20 13:09:46 +00:00
import Owner
import Web.JWT
2022-08-10 15:17:47 +00:00
-- | 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
2022-08-11 22:30:24 +00:00
-- | Type to represent a Xero access token
data XeroToken =
XeroToken
{ t_id :: Maybe ObjectId
, t_address :: T.Text
, t_access :: T.Text
2022-08-18 19:21:32 +00:00
, t_expires :: Integer
2022-08-11 22:30:24 +00:00
, t_refresh :: T.Text
2022-08-18 19:21:32 +00:00
, t_accdte :: UTCTime
, t_refdte :: UTCTime
2022-09-06 19:01:14 +00:00
, t_code :: T.Text
2022-08-11 22:30:24 +00:00
}
deriving (Eq, Show)
instance ToJSON XeroToken where
2022-09-06 19:01:14 +00:00
toJSON (XeroToken i a t e r aD d c) =
2022-08-11 22:30:24 +00:00
case i of
Just oid ->
object
[ "_id" .= show oid
, "address" .= a
, "accessToken" .= t
, "expires" .= e
, "refreshToken" .= r
2022-08-18 19:21:32 +00:00
, "accExpires" .= aD
, "refExpires" .= d
2022-09-06 19:01:14 +00:00
, "accCode" .= c
2022-08-11 22:30:24 +00:00
]
Nothing ->
object
[ "_id" .= ("" :: String)
, "address" .= a
, "accessToken" .= t
, "expires" .= e
, "refreshToken" .= r
2022-08-18 19:21:32 +00:00
, "accExpires" .= aD
, "refExpires" .= d
2022-09-06 19:01:14 +00:00
, "accCode" .= c
2022-08-11 22:30:24 +00:00
]
instance FromJSON XeroToken where
parseJSON =
withObject "XeroToken" $ \obj -> do
2022-08-18 19:21:32 +00:00
t <- obj .: "access_token"
e <- obj .: "expires_in"
r <- obj .: "refresh_token"
2022-08-11 22:30:24 +00:00
pure $
XeroToken
2022-08-18 19:21:32 +00:00
Nothing
""
2022-08-11 22:30:24 +00:00
t
e
r
2022-08-18 19:21:32 +00:00
(UTCTime (fromGregorian 2000 1 1) (secondsToDiffTime 0))
(UTCTime (fromGregorian 2000 1 1) (secondsToDiffTime 0))
2022-09-06 19:01:14 +00:00
""
2022-08-11 22:30:24 +00:00
instance Val XeroToken where
2022-09-06 19:01:14 +00:00
val (XeroToken i a t e r aD d c) =
2022-08-11 22:30:24 +00:00
if isJust i
then Doc
[ "_id" =: i
, "address" =: a
, "accessToken" =: t
, "expires" =: e
, "refreshToken" =: r
2022-08-18 19:21:32 +00:00
, "accExpires" =: aD
, "refExpires" =: d
2022-09-06 19:01:14 +00:00
, "accCode" =: c
2022-08-11 22:30:24 +00:00
]
else Doc
[ "address" =: a
, "accessToken" =: t
, "expires" =: e
, "refreshToken" =: r
2022-08-18 19:21:32 +00:00
, "accExpires" =: aD
, "refExpires" =: d
2022-09-08 14:44:45 +00:00
, "accCode" =: c
2022-08-11 22:30:24 +00:00
]
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
2022-08-18 19:21:32 +00:00
aD <- B.lookup "accExpires" d
2022-09-06 19:01:14 +00:00
dte <- B.lookup "refExpires" d
c <- B.lookup "accCode" d
Just (XeroToken i a t e r aD dte c)
2022-08-11 22:30:24 +00:00
cast' _ = Nothing
2022-09-08 14:44:45 +00:00
processToken :: XeroToken -> T.Text -> T.Text -> IO XeroToken
processToken t a c = do
2022-08-18 19:21:32 +00:00
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)
2022-09-08 14:44:45 +00:00
c
2022-08-18 19:21:32 +00:00
2022-08-20 13:09:46 +00:00
-- |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
2022-09-08 16:26:54 +00:00
, xi_currRate :: Maybe Double
2022-08-20 13:09:46 +00:00
, 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"
2022-09-08 16:26:54 +00:00
cR <- obj .:? "CurrencyRate"
2022-09-01 15:42:41 +00:00
total <- obj .: "AmountDue"
2022-08-20 13:09:46 +00:00
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
2022-08-10 15:17:47 +00:00
-- Database actions
findXero :: Action IO (Maybe Document)
findXero = findOne (select [] "xero")
2022-08-11 22:30:24 +00:00
2022-08-18 19:21:32 +00:00
upsertToken :: XeroToken -> Action IO (Maybe Document)
2022-08-11 22:30:24 +00:00
upsertToken t = do
let token = val t
case token of
2022-08-18 19:21:32 +00:00
Doc d -> do
2022-09-08 15:52:32 +00:00
upsert (select ["address" =: t_address t] "xerotokens") d
findOne (select ["address" =: t_address t] "xerotokens")
2022-08-18 19:21:32 +00:00
_ -> return Nothing
2022-08-11 22:30:24 +00:00
findToken :: T.Text -> Action IO (Maybe Document)
findToken a = findOne (select ["address" =: a] "xerotokens")
2022-08-18 19:21:32 +00:00
-- | Function to request accesstoken
2022-08-20 13:09:46 +00:00
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 ->
2022-08-18 19:21:32 +00:00
"grant_type=authorization_code&code=" <>
2022-09-07 22:20:43 +00:00
code <> "&redirect_uri=http://localhost:4200/xeroauth"
2022-08-20 13:09:46 +00:00
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)
2022-09-08 14:44:45 +00:00
let accCode = t_code <$> (token >>= cast' . Doc)
pToken <- processToken newToken address (fromMaybe "" accCode)
2022-08-20 13:09:46 +00:00
--print pToken
_ <- access pipe master dbName $ upsertToken pToken
_ <- getTenantId pipe dbName pToken
return True
_ -> do
print res
return False
2022-09-06 19:01:14 +00:00
-- |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]]
2022-08-20 13:09:46 +00:00
-- |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
2022-08-18 19:21:32 +00:00
let req =
2022-08-20 13:09:46 +00:00
addRequestHeader hContentType "application/json" $
setRequestQueryString [("authEventId", Just (encodeUtf8 e))] $
2022-08-18 19:21:32 +00:00
setRequestSecure True $
2022-08-20 13:09:46 +00:00
setRequestBearerAuth (encodeUtf8 $ t_access t) $
2022-08-18 19:21:32 +00:00
setRequestPort 443 $
2022-08-20 13:09:46 +00:00
setRequestPath "/connections" $
setRequestHost "api.xero.com" $
setRequestMethod "GET" defaultRequest
2022-08-18 19:21:32 +00:00
res <- httpJSON req
2022-08-20 13:09:46 +00:00
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"
2022-08-20 13:09:46 +00:00
_ -> 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
2022-09-07 22:20:43 +00:00
let xToken = cast' . Doc =<< token
case xToken of
2022-08-20 13:09:46 +00:00
Nothing -> return Nothing
2022-09-07 22:20:43 +00:00
Just xT -> do
let aToken = t_access xT
o <- access pipe master dbName $ findOwner address
let ownerData = cast' . Doc =<< o
case ownerData of
2022-08-20 13:09:46 +00:00
Nothing -> return Nothing
2022-09-07 22:20:43 +00:00
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 -> IO ()
payXeroInvoice pipe dbName inv address amt = do
token <- access pipe master dbName $ findToken address
let aToken = t_access <$> (token >>= cast' . Doc)
2022-09-08 19:05:42 +00:00
let aCode = t_code <$> (token >>= cast' . Doc)
2022-09-07 22:20:43 +00:00
o <- access pipe master dbName $ findOwner address
let tenant = ocrmToken <$> (o >>= cast' . Doc)
2022-09-08 19:05:42 +00:00
today <- getCurrentTime
if isJust aToken && isJust tenant && isJust aCode
2022-09-07 22:20:43 +00:00
then do
let req =
2022-09-08 19:05:42 +00:00
setRequestBodyJSON
(object
[ "Invoice" .= object ["InvoiceNumber" .= inv]
, "Account" .= object ["Code" .= fromMaybe "" aCode]
, "Date" .= utctDay today
, "Amount" .= amt
]) $
2022-09-07 22:20:43 +00:00
addRequestHeader "Accept" "application/json" $
addRequestHeader "Xero-tenant-id" (encodeUtf8 $ fromMaybe "" tenant) $
setRequestSecure True $
setRequestBearerAuth (encodeUtf8 (fromMaybe "" aToken)) $
setRequestPort 443 $
2022-09-08 19:05:42 +00:00
setRequestPath "/api.xro/2.0/Payments" $
2022-09-07 22:20:43 +00:00
setRequestHost "api.xero.com" $
setRequestMethod "PUT" defaultRequest
res <- httpJSON req
print (res :: Response Object)
else error "Invalid parameters"