diff --git a/src/Xero.hs b/src/Xero.hs index 4aa65b7..d5c80ce 100644 --- a/src/Xero.hs +++ b/src/Xero.hs @@ -2,13 +2,19 @@ module Xero where +import Control.Monad.IO.Class import Data.Aeson import qualified Data.Bson as B +import qualified Data.ByteString.Lazy as BL 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 -- | Type to represent a Xero app configuration data Xero = @@ -38,13 +44,15 @@ data XeroToken = { t_id :: Maybe ObjectId , t_address :: T.Text , t_access :: T.Text - , t_expires :: UTCTime + , t_expires :: Integer , t_refresh :: T.Text + , t_accdte :: UTCTime + , t_refdte :: UTCTime } deriving (Eq, Show) instance ToJSON XeroToken where - toJSON (XeroToken i a t e r) = + toJSON (XeroToken i a t e r aD d) = case i of Just oid -> object @@ -53,6 +61,8 @@ instance ToJSON XeroToken where , "accessToken" .= t , "expires" .= e , "refreshToken" .= r + , "accExpires" .= aD + , "refExpires" .= d ] Nothing -> object @@ -61,28 +71,28 @@ instance ToJSON XeroToken where , "accessToken" .= t , "expires" .= e , "refreshToken" .= r + , "accExpires" .= aD + , "refExpires" .= d ] instance FromJSON XeroToken where parseJSON = withObject "XeroToken" $ \obj -> do - i <- obj .: "_id" - a <- obj .: "address" - t <- obj .: "accessToken" - e <- obj .: "expires" - r <- obj .: "refreshToken" + t <- obj .: "access_token" + e <- obj .: "expires_in" + r <- obj .: "refresh_token" pure $ XeroToken - (if not (null i) - then Just (read i) - else Nothing) - a + 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) = + val (XeroToken i a t e r aD d) = if isJust i then Doc [ "_id" =: i @@ -90,12 +100,16 @@ instance Val XeroToken where , "accessToken" =: t , "expires" =: e , "refreshToken" =: r + , "accExpires" =: aD + , "refExpires" =: d ] else Doc [ "address" =: a , "accessToken" =: t , "expires" =: e , "refreshToken" =: r + , "accExpires" =: aD + , "refExpires" =: d ] cast' (Doc d) = do i <- B.lookup "_id" d @@ -103,19 +117,79 @@ instance Val XeroToken where t <- B.lookup "accessToken" d e <- B.lookup "expires" d r <- B.lookup "refreshToken" d - Just (XeroToken i a t e r) + aD <- B.lookup "accExpires" d + d <- B.lookup "refExpires" d + Just (XeroToken i a t e r aD d) cast' _ = Nothing +processToken :: XeroToken -> T.Text -> IO XeroToken +processToken t a = 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) + -- Database actions findXero :: Action IO (Maybe Document) findXero = findOne (select [] "xero") -upsertToken :: XeroToken -> Action IO () +upsertToken :: XeroToken -> Action IO (Maybe Document) upsertToken t = do let token = val t case token of - Doc d -> upsert (select ["address" =: t_address t] "xerotokens") d - _ -> return () + 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") + +-- | 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 = + "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 + _ <- f $ upsertToken pToken + return True + _ -> do + print res + return False diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 9c3fae2..9ae5bd8 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -497,6 +497,27 @@ routes pipe config = do [ "message" .= ("Xero config found!" :: String) , "xeroConfig" .= toJSON (c :: Xero) ]) + get "/api/xerotoken" $ do + code <- param "code" + address <- param "address" + xeroConfig <- liftIO $ run findXero + case xeroConfig of + Nothing -> status noContent204 + Just x -> do + let xConfig = cast' (Doc x) + case xConfig of + Nothing -> status noContent204 + Just c -> do + res <- + liftIO $ + requestXeroToken + (run :: Action IO (Maybe Document) -> IO (Maybe Document)) + c + code + address + if res + then status ok200 + else status noContent204 post "/api/xerotoken" $ do o <- jsonData let q = payload (o :: Payload XeroToken) @@ -881,7 +902,6 @@ updateLogins pipe config = do mapM_ (access pipe master db . ZGoBackend.addUser nodeUser nodePwd pipe db addr) parsed - putStrLn "Updated logins!" -- | Function to mark owners as paid checkPayments :: Pipe -> T.Text -> IO ()