zgo-backend/src/Xero.hs

{-# LANGUAGE OverloadedStrings #-}

module Xero where

import Data.Aeson
import qualified Data.Bson as B
import Data.Maybe
import qualified Data.Text as T
import Data.Time.Clock
import Database.MongoDB
import GHC.Generics

-- | 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 :: UTCTime
    , t_refresh :: T.Text
    }
  deriving (Eq, Show)

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

instance FromJSON XeroToken where
  parseJSON =
    withObject "XeroToken" $ \obj -> do
      i <- obj .: "_id"
      a <- obj .: "address"
      t <- obj .: "accessToken"
      e <- obj .: "expires"
      r <- obj .: "refreshToken"
      pure $
        XeroToken
          (if not (null i)
             then Just (read i)
             else Nothing)
          a
          t
          e
          r

instance Val XeroToken where
  val (XeroToken i a t e r) =
    if isJust i
      then Doc
             [ "_id" =: i
             , "address" =: a
             , "accessToken" =: t
             , "expires" =: e
             , "refreshToken" =: r
             ]
      else Doc
             [ "address" =: a
             , "accessToken" =: t
             , "expires" =: e
             , "refreshToken" =: r
             ]
  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
    Just (XeroToken i a t e r)
  cast' _ = Nothing

-- Database actions
findXero :: Action IO (Maybe Document)
findXero = findOne (select [] "xero")

upsertToken :: XeroToken -> Action IO ()
upsertToken t = do
  let token = val t
  case token of
    Doc d -> upsert (select ["address" =: t_address t] "xerotokens") d
    _ -> return ()

findToken :: T.Text -> Action IO (Maybe Document)
findToken a = findOne (select ["address" =: a] "xerotokens")