diff --git a/CHANGELOG.md b/CHANGELOG.md index c91ec3c..03e38c8 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,14 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] +### Added + +- New utility to refresh Xero tokens periodically. + +### Changed + +- Refactored code for requesting Xero tokens to make it reusable. + ## [1.1.1] - 2022-10-08 ### Changed diff --git a/app/Main.hs b/app/Server.hs similarity index 98% rename from app/Main.hs rename to app/Server.hs index 76b677f..5c6ee4f 100644 --- a/app/Main.hs +++ b/app/Server.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Main where +module Server where import Config import Control.Concurrent (forkIO) diff --git a/app/TokenRefresh.hs b/app/TokenRefresh.hs new file mode 100644 index 0000000..81b5168 --- /dev/null +++ b/app/TokenRefresh.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TokenRefresh where + +import Config +import Data.Time.Clock +import Database.MongoDB +import Xero + +main :: IO () +main = do + putStrLn "Reading config..." + now <- getCurrentTime + loadedConfig <- loadZGoConfig "zgo.cfg" + pipe <- connect $ host (c_dbHost loadedConfig) + let db = c_dbName loadedConfig + j <- + access + pipe + master + db + (auth (c_dbUser loadedConfig) (c_dbPassword loadedConfig)) + if j + then putStrLn "Connected to MongoDB!" + else fail "MongoDB connection failed!" + credsData <- access pipe master db findXero + let creds = cast' . Doc =<< credsData + tokens <- access pipe master db (findExpiringTokens now) + if not (null tokens) + then do + let t = map (cast' . Doc) tokens + case creds of + Just c -> mapM_ (refreshToken pipe db c "") t + Nothing -> fail "No credentials" + else putStrLn "No tokens to refresh1" diff --git a/package.yaml b/package.yaml index dad45bd..8a9115b 100644 --- a/package.yaml +++ b/package.yaml @@ -56,29 +56,57 @@ library: executables: zgo-backend-exe: - main: Main.hs + main: Server.hs source-dirs: app ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - - -Wall + - -main-is Server + - -threaded + - -rtsopts + - -with-rtsopts=-N + - -Wall dependencies: - - zgo-backend - - base - - scotty - - wai-extra - - securemem - - text - - aeson - - mongoDB - - http-types - - http-conduit - - time - - bytestring - - configurator - - warp-tls - - warp + - zgo-backend + - base + - scotty + - wai-extra + - securemem + - text + - aeson + - mongoDB + - http-types + - http-conduit + - time + - bytestring + - configurator + - warp-tls + - warp + zgo-token-refresh: + main: TokenRefresh.hs + source-dirs: app + ghc-options: + - -main-is TokenRefresh + - -threaded + - -rtsopts + - -with-rtsopts=-N + - -Wall + dependencies: + - base + - zgo-backend + - base + - scotty + - wai-extra + - securemem + - text + - aeson + - mongoDB + - http-types + - http-conduit + - time + - bytestring + - configurator + - warp-tls + - warp + tests: zgo-backend-test: diff --git a/src/Xero.hs b/src/Xero.hs index 8d67b4f..daa37fd 100644 --- a/src/Xero.hs +++ b/src/Xero.hs @@ -280,17 +280,24 @@ upsertToken t = do 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 1728000 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 oToken + +refreshToken :: Pipe -> T.Text -> Xero -> T.Text -> Maybe XeroToken -> IO Bool +refreshToken pipe dbName cred code token = do 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 + Just x -> "grant_type=refresh_token&refresh_token=" <> t_refresh x Nothing -> "grant_type=authorization_code&code=" <> code <> "&redirect_uri=http://localhost:4200/xeroauth" @@ -309,8 +316,10 @@ requestXeroToken pipe dbName cred code address = do case rCode of 200 -> do let newToken = getResponseBody (res :: Response XeroToken) - let accCode = t_code <$> (token >>= cast' . Doc) - pToken <- processToken newToken address (fromMaybe "" accCode) + let accCode = t_code <$> token + let address = t_address <$> token + pToken <- + processToken newToken (fromMaybe "" address) (fromMaybe "" accCode) --print pToken _ <- access pipe master dbName $ upsertToken pToken _ <- getTenantId pipe dbName pToken diff --git a/zgo-backend.cabal b/zgo-backend.cabal index 4e33148..72bedc9 100644 --- a/zgo-backend.cabal +++ b/zgo-backend.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: zgo-backend -version: 1.1.0 +version: 1.1.1 synopsis: Haskell Back-end for the ZGo point-of-sale application description: Please see the README on GitLab at category: Web @@ -70,12 +70,39 @@ library default-language: Haskell2010 executable zgo-backend-exe - main-is: Main.hs + main-is: Server.hs other-modules: + TokenRefresh Paths_zgo_backend hs-source-dirs: app - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + ghc-options: -main-is Server -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + aeson + , base + , bytestring + , configurator + , http-conduit + , http-types + , mongoDB + , scotty + , securemem + , text + , time + , wai-extra + , warp + , warp-tls + , zgo-backend + default-language: Haskell2010 + +executable zgo-token-refresh + main-is: TokenRefresh.hs + other-modules: + Server + Paths_zgo_backend + hs-source-dirs: + app + ghc-options: -main-is TokenRefresh -threaded -rtsopts -with-rtsopts=-N -Wall build-depends: aeson , base