diff --git a/package.yaml b/package.yaml index b280c86..0c772e6 100644 --- a/package.yaml +++ b/package.yaml @@ -51,6 +51,8 @@ library: - hexstring - configurator - scientific + - jwt + - containers executables: zgo-backend-exe: diff --git a/src/Order.hs b/src/Order.hs index 758c48b..226b2ea 100644 --- a/src/Order.hs +++ b/src/Order.hs @@ -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") diff --git a/src/Xero.hs b/src/Xero.hs index d5c80ce..e675042 100644 --- a/src/Xero.hs +++ b/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 diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 9ae5bd8..8b16439 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -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) diff --git a/zgo-backend.cabal b/zgo-backend.cabal index 8d64972..6584712 100644 --- a/zgo-backend.cabal +++ b/zgo-backend.cabal @@ -47,9 +47,11 @@ library , bson , bytestring , configurator + , containers , hexstring , http-conduit , http-types + , jwt , mongoDB , quickcheck-instances , random