[graphql] add some tests for un-prefix, metrics indent fixes

parent d380aafa
Pipeline #7196 passed with stages
in 54 minutes and 4 seconds
......@@ -11,6 +11,7 @@ Node API
-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Gargantext.Database.Action.Metrics
where
......@@ -42,7 +43,10 @@ import Gargantext.Database.Query.Table.Node.Select
import Gargantext.Prelude
getMetrics :: (HasNodeStory env err m)
=> CorpusId -> ListId -> TabType -> Maybe Limit
=> CorpusId
-> ListId
-> TabType
-> Maybe Limit
-> m (HashMap NgramsTerm (ListType, Maybe NgramsTerm), Vector (Scored NgramsTerm))
getMetrics cId listId tabType maybeLimit = do
(ngs, _, myCooc) <- getNgramsCooc cId listId tabType maybeLimit
......@@ -51,7 +55,10 @@ getMetrics cId listId tabType maybeLimit = do
getNgramsCooc :: (HasNodeStory env err m)
=> CorpusId -> ListId -> TabType -> Maybe Limit
=> CorpusId
-> ListId
-> TabType
-> Maybe Limit
-> m ( HashMap NgramsTerm (ListType, Maybe NgramsTerm)
, HashMap NgramsTerm (Maybe RootTerm)
, HashMap (NgramsTerm, NgramsTerm) Int
......@@ -83,7 +90,10 @@ updateNgramsOccurrences cId lId = do
updateNgramsOccurrences' :: (HasNodeStory env err m)
=> CorpusId -> ListId -> Maybe Limit -> TabType
=> CorpusId
-> ListId
-> Maybe Limit
-> TabType
-> m [Int]
updateNgramsOccurrences' cId lId maybeLimit tabType = do
......@@ -126,14 +136,20 @@ updateNgramsOccurrences' cId lId maybeLimit tabType = do
------------------------------------------------------------------------
-- Used for scores in Ngrams Table
getNgramsOccurrences :: (HasNodeStory env err m)
=> CorpusId -> ListId -> TabType -> Maybe Limit
=> CorpusId
-> ListId
-> TabType
-> Maybe Limit
-> m (HashMap NgramsTerm Int)
getNgramsOccurrences c l t ml = HM.map Set.size <$> getNgramsContexts c l t ml
getNgramsContexts :: (HasNodeStory env err m)
=> CorpusId -> ListId -> TabType -> Maybe Limit
=> CorpusId
-> ListId
-> TabType
-> Maybe Limit
-> m (HashMap NgramsTerm (Set ContextId))
getNgramsContexts cId lId tabType maybeLimit = do
(_ngs', ngs) <- getNgrams lId tabType
......@@ -149,7 +165,8 @@ getNgramsContexts cId lId tabType maybeLimit = do
------------------------------------------------------------------------
updateContextScore :: (HasNodeStory env err m)
=> CorpusId -> ListId
=> CorpusId
-> ListId
-> m [Int]
updateContextScore cId lId = do
......@@ -186,26 +203,37 @@ updateContextScore cId lId = do
-- Used for scores in Doc Table
getContextsNgramsScore :: (HasNodeStory env err m)
=> CorpusId -> ListId -> TabType -> ListType -> Maybe Limit
=> CorpusId
-> ListId
-> TabType
-> ListType
-> Maybe Limit
-> m (Map ContextId Int)
getContextsNgramsScore cId lId tabType listType maybeLimit
= Map.map Set.size <$> getContextsNgrams cId lId tabType listType maybeLimit
-- | Given corpus, list, tabType, return a map of contexts to set of
-- ngrams terms
getContextsNgrams :: (HasNodeStory env err m)
=> CorpusId -> ListId -> TabType -> ListType -> Maybe Limit
=> CorpusId
-> ListId
-> TabType
-> ListType
-> Maybe Limit
-> m (Map ContextId (Set NgramsTerm))
getContextsNgrams cId lId tabType listType maybeLimit = do
(ngs', ngs) <- getNgrams lId tabType
lIds <- selectNodesWithUsername NodeList userMaster
result <- groupNodesByNgrams ngs <$> getContextsByNgramsOnlyUser
cId
(lIds <> [lId])
(ngramsTypeFromTabType tabType)
( take' maybeLimit
$ HM.keys
$ HM.filter (\v -> fst v == listType) ngs'
)
result <- groupNodesByNgrams ngs <$> getContextsByNgramsOnlyUser cId
(lIds <> [lId])
(ngramsTypeFromTabType tabType)
( take' maybeLimit
$ HM.keys
$ HM.filter (\v -> fst v == listType) ngs'
)
-- printDebug "getCoocByNgrams" result
pure $ Map.fromListWith (<>)
$ List.concat
......@@ -218,18 +246,19 @@ getContextsNgrams cId lId tabType listType maybeLimit = do
getNgrams :: (HasNodeStory env err m)
=> ListId -> TabType
=> ListId
-> TabType
-> m ( HashMap NgramsTerm (ListType, Maybe NgramsTerm)
, HashMap NgramsTerm (Maybe RootTerm)
)
getNgrams lId tabType = do
lists <- mapTermListRoot [lId] (ngramsTypeFromTabType tabType) <$> getRepo [lId]
-- TODO filterListWithRoot [MapTerm, StopTerm, CandidateTerm] lists
let maybeSyn = HM.unions $ map (\t -> filterListWithRoot t lists)
[[MapTerm], [StopTerm], [CandidateTerm]]
pure (lists, maybeSyn)
-- Some useful Tools
take' :: Maybe Limit -> [a] -> [a]
take' Nothing xs = xs
......
......@@ -7,14 +7,16 @@ module Test.API.GraphQL (
tests
) where
import Gargantext.API.Admin.Auth.Types (authRes_token, authRes_tree_id, authRes_user_id)
import Gargantext.Core.Types.Individu
import Prelude
import Gargantext.Database.Admin.Types.Node (UserId(..))
import Gargantext.Prelude
import Servant.Auth.Client ()
import Test.API.Setup (withTestDBAndPort, dbEnvSetup, SpecContext (..))
import Test.Hspec
import Test.Hspec.Wai.Internal (withApplication)
import Test.Hspec.Wai.JSON (json)
import Test.Utils (protected, protectedNewError, shouldRespondWithFragment, shouldRespondWithFragmentCustomStatus, withValidLogin)
import Test.Utils (protected, protectedNewError, shouldRespondWithFragment, shouldRespondWithFragmentCustomStatus, withValidLogin, withValidLoginA)
import Text.RawString.QQ (r)
tests :: Spec
......@@ -23,10 +25,21 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
describe "get_user_infos" $ do
it "allows 'alice' to see her own info" $ \SpecContext{..} -> do
withApplication _sctx_app $ do
withValidLogin _sctx_port "alice" (GargPassword "alice") $ \_clientEnv token -> do
withValidLoginA _sctx_port "alice" (GargPassword "alice") $ \_clientEnv authRes -> do
liftIO $ (authRes ^. authRes_user_id) `shouldBe` (UnsafeMkUserId 2)
let query = [r| { "query": "{ user_infos(user_id: 2) { ui_id, ui_email } }" } |]
let expected = [json| {"data":{"user_infos":[{"ui_id":2,"ui_email":"alice@gargan.text"}]}} |]
protected token "POST" "/gql" query `shouldRespondWithFragment` expected
protected (authRes ^. authRes_token) "POST" "/gql" query `shouldRespondWithFragment` expected
describe "get_users" $ do
it "allows 'alice' to see her user info" $ \SpecContext{..} -> do
withApplication _sctx_app $ do
withValidLoginA _sctx_port "alice" (GargPassword "alice") $ \_clientEnv authRes -> do
-- epo_api_user is a renamed field, we check if it's correctly un-prefixed
liftIO $ (authRes ^. authRes_tree_id) `shouldBe` 8
let query = [r| { "query": "{ users(user_id: 8) { u_username, u_hyperdata { epo_api_user } } }" } |]
let expected = [json| {"data":{"users":[{"u_username":"alice","u_hyperdata":{"epo_api_user": null}}]}} |]
protected (authRes ^. authRes_token) "POST" "/gql" query `shouldRespondWithFragment` expected
describe "nodes" $ do
it "returns node_type" $ \(SpecContext _testEnv port app _) -> do
......
......@@ -27,6 +27,7 @@ module Test.Utils (
, waitForTSem
, waitUntil
, withValidLogin
, withValidLoginA
) where
import Control.Concurrent.STM.TChan (TChan, readTChan)
......@@ -44,7 +45,7 @@ import Data.Text.Encoding qualified as TE
import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.Encoding qualified as TLE
import Data.TreeDiff
import Gargantext.API.Admin.Auth.Types (AuthRequest(..), Token, authRes_token)
import Gargantext.API.Admin.Auth.Types (AuthRequest(..), AuthResponse, Token, authRes_token)
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Routes.Types (xGargErrorScheme)
import Gargantext.Core.Notifications.Dispatcher.Types qualified as DT
......@@ -208,8 +209,13 @@ postJSONUrlEncoded tkn url queryPaths = do
Left err -> Prelude.fail $ "postJSONUrlEncoded failed when parsing " <> show (typeRep $ Proxy @a) <> ": " <> err <> "\nPayload was: " <> (T.unpack . TL.toStrict . TLE.decodeUtf8 $ simpleBody)
Right x -> pure x
withValidLogin :: (MonadFail m, MonadIO m) => Port -> Username -> GargPassword -> (ClientEnv -> Token -> m a) -> m a
withValidLogin port ur pwd act = do
withValidLoginA :: (MonadFail m, MonadIO m)
=> Port
-> Username
-> GargPassword
-> (ClientEnv -> AuthResponse -> m a)
-> m a
withValidLoginA port ur pwd act = do
baseUrl <- liftIO $ parseBaseUrl "http://localhost"
manager <- liftIO $ newManager defaultManagerSettings
let clientEnv0 = mkClientEnv manager (baseUrl { baseUrlPort = port })
......@@ -219,8 +225,17 @@ withValidLogin port ur pwd act = do
Left err -> liftIO $ throwIO $ Prelude.userError (show err)
Right res -> do
traceEnabled <- isJust <$> liftIO (lookupEnv "GARG_DEBUG_LOGS")
let token = res ^. authRes_token
act (clientEnv0 { makeClientRequest = gargMkRequest traceEnabled }) token
act (clientEnv0 { makeClientRequest = gargMkRequest traceEnabled }) res
withValidLogin :: (MonadFail m, MonadIO m)
=> Port
-> Username
-> GargPassword
-> (ClientEnv -> Token -> m a)
-> m a
withValidLogin port ur pwd act =
withValidLoginA port ur pwd (\clientEnv authRes -> act clientEnv $ authRes ^. authRes_token)
-- | Allows to enable/disable logging of the input 'Request' to check what the
-- client is actually sending to the server.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment