Implement endpoints for Xero orders
This commit is contained in:
parent
c965951d0e
commit
fbc41f9333
GPG Key ID:
65122AD495A7F5B2
|
|
@ -51,6 +51,8 @@ library:
|
|||
- hexstring
|
||||
- configurator
|
||||
- scientific
|
||||
- jwt
|
||||
- containers
|
||||
|
||||
executables:
|
||||
zgo-backend-exe:
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
||||
|
|
|
|||
262
src/Xero.hs
262
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 ::
|
||||
(Action IO (Maybe Document) -> IO (Maybe Document))
|
||||
-> Xero
|
||||
-> T.Text
|
||||
-> T.Text
|
||||
-> IO Bool
|
||||
requestXeroToken f cred code address = do
|
||||
token <- f $ findToken address
|
||||
case token of
|
||||
Just xT -> do
|
||||
let xToken = cast' (Doc xT) :: Maybe XeroToken
|
||||
case xToken of
|
||||
Nothing -> return False
|
||||
Just x -> return True
|
||||
Nothing -> do
|
||||
let pars =
|
||||
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 =
|
||||
setRequestBodyLBS (BL.fromStrict (encodeUtf8 pars)) $
|
||||
addRequestHeader hContentType "application/x-www-form-urlencoded" $
|
||||
addRequestHeader hContentType "application/json" $
|
||||
setRequestQueryString [("authEventId", Just (encodeUtf8 e))] $
|
||||
setRequestSecure True $
|
||||
setRequestBasicAuth
|
||||
(encodeUtf8 $ x_clientId cred)
|
||||
(encodeUtf8 $ x_clientSecret cred) $
|
||||
setRequestHost "identity.xero.com" $
|
||||
setRequestBearerAuth (encodeUtf8 $ t_access t) $
|
||||
setRequestPort 443 $
|
||||
setRequestMethod "POST" $
|
||||
setRequestPath "/connect/token" defaultRequest
|
||||
setRequestPath "/connections" $
|
||||
setRequestHost "api.xero.com" $
|
||||
setRequestMethod "GET" 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
|
||||
_ <- f $ upsertToken pToken
|
||||
return True
|
||||
_ -> do
|
||||
print res
|
||||
return False
|
||||
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
|
||||
let invData =
|
||||
getResponseBody (res :: Response XeroInvResponse)
|
||||
return $ Just (head $ xir_invs invData)
|
||||
_ -> return Nothing
|
||||
|
|
|
|||
|
|
@ -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 $
|
||||
requestXeroToken
|
||||
(run :: Action IO (Maybe Document) -> IO (Maybe Document))
|
||||
c
|
||||
code
|
||||
address
|
||||
liftIO $ requestXeroToken pipe (c_dbName config) 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)
|
||||
|
|
|
|||
|
|
@ -47,9 +47,11 @@ library
|
|||
, bson
|
||||
, bytestring
|
||||
, configurator
|
||||
, containers
|
||||
, hexstring
|
||||
, http-conduit
|
||||
, http-types
|
||||
, jwt
|
||||
, mongoDB
|
||||
, quickcheck-instances
|
||||
, random
|
||||
|
|
|
|||
Loading…
Reference in New Issue