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

src/Gargantext/Database/Action/Metrics.hs

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

test/Test/API/GraphQL.hs

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

test/Test/Utils.hs

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