Implement Xero token

CHANGELOG.md

@@ -8,6 +8,9 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
 
 ### Added
 
+- Type `XeroToken`
+- API endpoint to save a `XeroToken`
+- API endpoint to query a Xero access token
 - Type `Xero`
 - API endpoint to query Xero configuration
 - Field `crmToken` for `Owner`

src/Xero.hs

@@ -4,7 +4,9 @@ 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
 
@@ -30,6 +32,90 @@ instance Val Xero where
     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")

src/ZGoBackend.hs

@@ -469,7 +469,7 @@ routes pipe config = do
     basicAuth
       (\u p -> return $ u == "user" && secureMemFromByteString p == passkey)
       "ZGo Backend"
-    --Get list of countries for UI
+  --Get list of countries for UI
   get "/api/countries" $ do
     countries <- liftIO $ run listCountries
     case countries of
@@ -481,7 +481,7 @@ routes pipe config = do
              [ "message" .= ("Country data found" :: String)
              , "countries" .= toJSON (map parseCountryBson countries)
              ])
-    --Get user associated with session
+  --Get Xero credentials
   get "/api/xero" $ do
     xeroConfig <- liftIO $ run findXero
     case xeroConfig of
@@ -497,6 +497,28 @@ routes pipe config = do
                  [ "message" .= ("Xero config found!" :: String)
                  , "xeroConfig" .= toJSON (c :: Xero)
                  ])
+  post "/api/xerotoken" $ do
+    o <- jsonData
+    let q = payload (o :: Payload XeroToken)
+    _ <- liftIO $ run (upsertToken q)
+    status created201
+  get "/api/xerotoken" $ do
+    a <- param "address"
+    t <- liftIO $ run (findToken a)
+    case t of
+      Nothing -> status noContent204
+      Just t1 -> do
+        let xToken = cast' (Doc t1)
+        case xToken of
+          Nothing -> status noContent204
+          Just xt -> do
+            status ok200
+            Web.Scotty.json
+              (object
+                 [ "message" .= ("Token found" :: String)
+                 , "token" .= toJSON (xt :: XeroToken)
+                 ])
+  --Get user associated with session
   get "/api/user" $ do
     sess <- param "session"
     user <- liftIO $ run (findUser sess)

test/Spec.hs

@@ -33,6 +33,7 @@ import Test.QuickCheck.Gen
 import Test.QuickCheck.Monadic
 import User
 import Web.Scotty
+import Xero
 import ZGoBackend
 import ZGoTx
 
@@ -102,6 +103,12 @@ main = do
             req <- testGet "/api/xero" []
             res <- httpJSON req
             getResponseStatus (res :: Response A.Value) `shouldBe` ok200
+        describe "xero token endpoint" $ do
+          prop "save token" testTokenAdd
+          it "return token" $ do
+            req <- testGet "/api/xerotoken" [("address", Just "Zaddy")]
+            res <- httpLBS req
+            getResponseStatus res `shouldBe` ok200
         describe "User endpoint" $ do
           it "returns a user for a session" $ do
             req <-
@@ -268,6 +275,21 @@ main = do
             case o1 of
               Nothing -> True `shouldBe` False
               Just o2 -> qpaid o2 `shouldBe` True
+        describe "Xero data" $ do
+          it "token is saved" $ \p -> do
+            let myToken =
+                  XeroToken
+                    Nothing
+                    "Zaddy"
+                    "superFakeToken123"
+                    (UTCTime (fromGregorian 2022 9 16) (secondsToDiffTime 0))
+                    "anotherSuperFakeToken"
+            _ <- access p master "test" $ upsertToken myToken
+            t <- access p master "test" $ findToken "Zaddy"
+            let t1 = (cast' . Doc) =<< t
+            case t1 of
+              Nothing -> True `shouldBe` False
+              Just t2 -> t_address t2 `shouldBe` "Zaddy"
         describe "Zcash transactions" $ do
           xit "logins are added to db" $ \p -> do
             _ <-
@@ -456,6 +478,14 @@ testItemAdd i = do
     res <- httpLBS req
     assert $ getResponseStatus res == created201
 
+testTokenAdd :: XeroToken -> Property
+testTokenAdd t = do
+  monadicIO $ do
+    req <-
+      run $ testPostJson "/api/xerotoken" (A.object ["payload" A..= A.toJSON t])
+    res <- httpLBS req
+    assert $ getResponseStatus res == created201
+
 -- | Open the MongoDB connection
 openDbConnection :: IO Pipe
 openDbConnection = do
@@ -628,3 +658,11 @@ instance Arbitrary Item where
     d <- arbitrary
     o <- arbitrary
     Item i n d o <$> arbitrary
+
+instance Arbitrary XeroToken where
+  arbitrary = do
+    i <- arbitrary
+    a <- arbitrary
+    t <- arbitrary
+    e <- arbitrary
+    XeroToken i a t e <$> arbitrary