Implement token refresh utility

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

app/Server.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Main where
+module Server where
 
 import Config
 import Control.Concurrent (forkIO)

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"

package.yaml

@@ -56,9 +56,10 @@ library:
 
 executables:
   zgo-backend-exe:
-    main:                Main.hs
+    main:                Server.hs
     source-dirs:         app
     ghc-options:
+            - -main-is Server
             - -threaded
             - -rtsopts
             - -with-rtsopts=-N
@@ -79,6 +80,33 @@ executables:
             - 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:

src/Xero.hs

@@ -280,16 +280,23 @@ 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
           Nothing ->
             "grant_type=authorization_code&code=" <>
@@ -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

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 <https://gitlab.com/pitmutt/zgo-backend#readme>
 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