diff --git a/CHANGELOG.md b/CHANGELOG.md index 2aa5a67..463c56c 100644 --- a/CHANGELOG.md +++ b/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` diff --git a/src/Xero.hs b/src/Xero.hs index 29ef1ae..4aa65b7 100644 --- a/src/Xero.hs +++ b/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") diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index a0e8402..08d76c4 100644 --- a/src/ZGoBackend.hs +++ b/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) diff --git a/test/Spec.hs b/test/Spec.hs index 8d18d99..4b80bfe 100644 --- a/test/Spec.hs +++ b/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