Merge branch 'dev' into 224-dev-understanding-ngrams

src/Gargantext/API/Admin/Orchestrator/Types.hs

@@ -18,12 +18,11 @@ module Gargantext.API.Admin.Orchestrator.Types
   where
 
 import Data.Aeson (genericParseJSON, genericToJSON)
-import Data.Morpheus.Types ( GQLType, VisitType(visitFieldNames) )
+import Data.Morpheus.Types ( GQLType(..), DropNamespace(..), typeDirective )
 import Data.Swagger (ToSchema, URL, declareNamedSchema, defaultSchemaOptions, genericDeclareNamedSchemaUnrestricted)
 -- import Gargantext.API.GraphQL.UnPrefix qualified as GQLU
 import Gargantext.Core.Types (TODO(..))
 import Gargantext.Core.Utils.Aeson (jsonOptions)
-import Gargantext.Core.Utils.Prefix (dropPrefixT)
 import Gargantext.Prelude
 import PUBMED.Types qualified as PUBMED
 import Test.QuickCheck (elements)
@@ -83,9 +82,8 @@ instance ToJSON ScraperEvent where
 instance FromJSON ScraperEvent where
   parseJSON = genericParseJSON $ jsonOptions "_scev_"
 instance ToSchema ScraperEvent  -- TODO _scev_ prefix
-instance GQLType ScraperEvent
-instance VisitType ScraperEvent where
-  visitFieldNames _ = dropPrefixT "_scev_"
+instance GQLType ScraperEvent where
+  directives _ = typeDirective DropNamespace { dropNamespace = "_scev_" }
 
 
 data JobLog = JobLog
@@ -112,7 +110,5 @@ instance ToJSON JobLog where
 instance FromJSON JobLog where
   parseJSON = genericParseJSON $ jsonOptions "_scst_"
 instance ToSchema JobLog -- TODO _scst_ prefix
-instance GQLType JobLog
---   typeOptions _ = GQLU.unPrefix "_scst_"
-instance VisitType JobLog where
-  visitFieldNames _ = dropPrefixT "_scst_"
+instance GQLType JobLog where
+  directives _ = typeDirective DropNamespace { dropNamespace = "_scst_" }

src/Gargantext/Core/Utils/Prefix.hs

@@ -20,9 +20,7 @@ import Data.Aeson (Value, defaultOptions, parseJSON)
 import Data.Aeson.TH (Options, fieldLabelModifier, omitNothingFields, sumEncoding, SumEncoding(UntaggedValue))
 import Data.Aeson.Types (Parser)
 import Data.Char (toLower)
-import Data.Maybe (fromMaybe)
 import Data.Swagger.SchemaOptions (SchemaOptions, fromAesonOptions)
-import Data.Text qualified as T
 import Prelude
 import Text.Read (readMaybe)
 
@@ -65,6 +63,3 @@ parseJSONFromString v = do
   case readMaybe (numString :: String) of
     Nothing -> fail $ "Invalid number for TransactionID: " ++ show v -- TODO error message too specific
     Just n -> pure n
-
-dropPrefixT :: T.Text -> T.Text -> T.Text
-dropPrefixT prefix input = fromMaybe input (T.stripPrefix prefix input)

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

src/Gargantext/Database/Admin/Types/Hyperdata/Contact.hs

@@ -19,10 +19,9 @@ Portability : POSIX
 module Gargantext.Database.Admin.Types.Hyperdata.Contact
   where
 
-import Data.Morpheus.Types (GQLType, VisitType(visitFieldNames))
+import Data.Morpheus.Types (GQLType(..), DropNamespace(..), typeDirective)
 import Data.Time.Segment (jour)
 import Gargantext.Core.Text (HasText(..))
-import Gargantext.Core.Utils.Prefix (dropPrefixT)
 import Gargantext.Database.Admin.Types.Hyperdata.Prelude
 import Gargantext.Prelude
 import Gargantext.Utils.UTCTime ( NUTCTime(..) )
@@ -37,9 +36,8 @@ data HyperdataContact =
                    , _hc_lastValidation  :: Maybe Text -- TODO UTCTime
   } deriving (Eq, Show, Generic)
 
-instance GQLType HyperdataContact
-instance VisitType HyperdataContact where
-  visitFieldNames _ = dropPrefixT "_hc_"
+instance GQLType HyperdataContact where
+  directives _ = typeDirective DropNamespace { dropNamespace = "_hc_" }
 
 instance HasText HyperdataContact
   where
@@ -94,9 +92,8 @@ data ContactWho =
              , _cw_description :: Maybe Text
   } deriving (Eq, Show, Generic)
 
-instance GQLType ContactWho
-instance VisitType ContactWho where
-  visitFieldNames _ = dropPrefixT "_cw_"
+instance GQLType ContactWho where
+  directives _ = typeDirective DropNamespace { dropNamespace = "_cw_" }
 
 type FirstName = Text
 type LastName  = Text
@@ -129,9 +126,8 @@ data ContactWhere =
                , _cw_exit         :: Maybe NUTCTime
   } deriving (Eq, Show, Generic)
 
-instance GQLType ContactWhere
-instance VisitType ContactWhere where
-  visitFieldNames _ = dropPrefixT "_cw_"
+instance GQLType ContactWhere where
+  directives _ = typeDirective DropNamespace { dropNamespace = "_cw_" }
 
 defaultContactWhere :: ContactWhere
 defaultContactWhere =
@@ -152,9 +148,8 @@ data ContactTouch =
                   , _ct_url       :: Maybe Text
   } deriving (Eq, Show, Generic)
 
-instance GQLType ContactTouch
-instance VisitType ContactTouch where
-  visitFieldNames _ = dropPrefixT "_ct_"
+instance GQLType ContactTouch where
+  directives _ = typeDirective DropNamespace { dropNamespace = "_ct_" }
 
 defaultContactTouch :: ContactTouch
 defaultContactTouch =

src/Gargantext/Database/Admin/Types/Hyperdata/User.hs

@@ -18,14 +18,13 @@ Portability : POSIX
 module Gargantext.Database.Admin.Types.Hyperdata.User
   where
 
-import Data.Morpheus.Types (GQLType, VisitType(visitFieldNames))
+import Data.Morpheus.Types (GQLType(..), DropNamespace(..), typeDirective)
 import Gargantext.Core (Lang(..))
-import Gargantext.Core.Utils.Prefix (dropPrefixT)
 import Gargantext.Database.Admin.Types.Hyperdata.Prelude
 import Gargantext.Database.Admin.Types.Hyperdata.Contact
 import Gargantext.Database.Admin.Types.Node (DocumentId)
 import Gargantext.Prelude
-import qualified PUBMED.Types as PUBMED
+import PUBMED.Types qualified as PUBMED
 
 -- import Gargantext.Database.Schema.Node -- (Node(..))
 
@@ -38,20 +37,17 @@ data HyperdataUser =
                    , _hu_epo_api_token  :: !(Maybe Text)
                    } deriving (Eq, Show, Generic)
 
-instance GQLType HyperdataUser
-instance VisitType HyperdataUser where
-  visitFieldNames _ = dropPrefixT "_hu_"
+instance GQLType HyperdataUser where
+  directives _ = typeDirective DropNamespace { dropNamespace = "_hu_" }
 
 data HyperdataPrivate =
      HyperdataPrivate { _hpr_password :: !Text
                       , _hpr_lang     :: !Lang
                       }
-     deriving (Eq, Show, Generic, GQLType)
+     deriving (Eq, Show, Generic)
 
--- instance GQLType HyperdataPrivate where
---   typeOptions _ = GAGU.unPrefix "_hpr_"
-instance VisitType HyperdataPrivate where
-  visitFieldNames _ = dropPrefixT "_hpr_"
+instance GQLType HyperdataPrivate where
+  directives _ = typeDirective DropNamespace { dropNamespace = "_hpr_" }
 
 
 data HyperdataPublic =
@@ -60,9 +56,8 @@ data HyperdataPublic =
                      }
      deriving (Eq, Show, Generic)
 
-instance GQLType HyperdataPublic
-instance VisitType HyperdataPublic where
-  visitFieldNames _ = dropPrefixT "_hpu_"
+instance GQLType HyperdataPublic where
+  directives _ = typeDirective DropNamespace { dropNamespace = "_hpu_" }
 
 -- | Default
 defaultHyperdataUser :: HyperdataUser

src/Gargantext/Database/Schema/User.hs

@@ -19,12 +19,12 @@ Functions to deal with users, database side.
 
 module Gargantext.Database.Schema.User where
 
-import Data.Morpheus.Types (GQLType, VisitType(visitFieldNames))
+import Data.Morpheus.Types (GQLType(..), DropNamespace(..), typeDirective)
 import Data.Time (UTCTime)
 import Database.PostgreSQL.Simple.FromField (FromField, fromField)
 -- import Gargantext.API.GraphQL.UnPrefix qualified as GAGU
 import Gargantext.Core.Types.Individu (GargPassword, toGargPassword)
-import Gargantext.Core.Utils.Prefix (unPrefix, dropPrefixT)
+import Gargantext.Core.Utils.Prefix (unPrefix)
 import Gargantext.Database.Prelude (fromField')
 import Gargantext.Prelude
 
@@ -44,9 +44,8 @@ data UserLight = UserLight { userLight_id                   :: !UserId
                            , userLight_password             :: !GargPassword
                            , userLight_forgot_password_uuid :: !(Maybe Text)
                            } deriving (Show, Generic)
-instance GQLType UserLight
-instance VisitType UserLight where
-  visitFieldNames _ = dropPrefixT "userLight_"
+instance GQLType UserLight where
+  directives _ = typeDirective DropNamespace { dropNamespace = "userLight_" }
 
 toUserLight :: UserDB -> UserLight
 toUserLight (UserDB { user_id

test/Test/API/GraphQL.hs

+
+{-# LANGUAGE QuasiQuotes      #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies     #-}
-{-# LANGUAGE QuasiQuotes      #-}
 {-# OPTIONS_GHC -Wno-orphans  #-}
 
 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,17 +26,28 @@ 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
+            let expected = [json| {data: {user_infos: [{ui_id: 2, ui_email: "alice@gargan.text" }] } } |]
+            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, public { pseudo }, private { lang } } } }" } |]
+            let expected = [json| {data: {users: [{u_username: "alice", u_hyperdata: {epo_api_user: null, public: { pseudo: "pseudo" }, private: { lang: "EN" } } }] } } |]
+            protected (authRes ^. authRes_token) "POST" "/gql" query `shouldRespondWithFragment` expected
 
     describe "nodes" $ do
       it "returns node_type" $ \(SpecContext _testEnv port app _) -> do
         withApplication app $ do
           withValidLogin port "gargantua" (GargPassword "secret_key") $ \_clientEnv token -> do
             let query = [r| { "query": "{ nodes(node_id: 2) { node_type } }" } |]
-            let expected = [json| {"data":{"nodes":[{"node_type":"NodeFolderPrivate"}]}} |]
+            let expected = [json| {data: {nodes: [{node_type: "NodeFolderPrivate" }]}} |]
             protected token "POST" "/gql" query `shouldRespondWithFragment` expected
 
     describe "check error format" $ 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.