Save Xero OAuth tokens to DB

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"
+      t <- obj .: "access_token"
-      a <- obj .: "address"
+      e <- obj .: "expires_in"
-      t <- obj .: "accessToken"
+      r <- obj .: "refresh_token"
-      e <- obj .: "expires"
-      r <- obj .: "refreshToken"
       pure $
         XeroToken
-          (if not (null i)
+          Nothing
-             then Just (read i)
+          ""
-             else Nothing)
-          a
           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
+    Doc d -> do
-    _ -> return ()
+      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

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 ()