449 lines
13 KiB
Haskell
449 lines
13 KiB
Haskell
{-# 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"
|