{-# 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"