zgo-backend/src/Xero.hs

{-# LANGUAGE OverloadedStrings #-}

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 =
  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
    }
  deriving (Eq, Show)

instance ToJSON XeroToken where
  toJSON (XeroToken i a t e r aD d) =
    case i of
      Just oid ->
        object
          [ "_id" .= show oid
          , "address" .= a
          , "accessToken" .= t
          , "expires" .= e
          , "refreshToken" .= r
          , "accExpires" .= aD
          , "refExpires" .= d
          ]
      Nothing ->
        object
          [ "_id" .= ("" :: String)
          , "address" .= a
          , "accessToken" .= t
          , "expires" .= e
          , "refreshToken" .= r
          , "accExpires" .= aD
          , "refExpires" .= d
          ]

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) =
    if isJust i
      then Doc
             [ "_id" =: i
             , "address" =: a
             , "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
    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
    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 (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")

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