Skip to content

haskell-gargantext
haskell-gargantext
Verified Commit 2fd0c7da authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski
Browse files
Options

[graphql] endpoint for contexts_for_ngrams

parent 1782fd9e
Pipeline #3588 failed with stage
    in 72 minutes and 21 seconds
    Hide whitespace changes
    Inline Side-by-side
    Showing with 509 additions and 362 deletions
    gargantext.cabal
    View file @ 2fd0c7da
    ......@@ -223,6 +223,7 @@ library
    Gargantext.Core.Text.Terms.Multi.PosTagging
    Gargantext.Core.Text.Terms.Multi.PosTagging.Types
    Gargantext.Core.Types.Phylo
    Gargantext.Core.Types.Search
    Gargantext.Core.Utils.DateUtils
    Gargantext.Core.Viz
    Gargantext.Core.Viz.Chart
    ......@@ -282,6 +283,7 @@ library
    Gargantext.Database.GargDB
    Gargantext.Database.Query
    Gargantext.Database.Query.Facet
    Gargantext.Database.Query.Facet.Types
    Gargantext.Database.Query.Filter
    Gargantext.Database.Query.Join
    Gargantext.Database.Query.Prelude
    ......
    src/Gargantext/API/GraphQL.hs
    View file @ 2fd0c7da
    ......@@ -66,16 +66,17 @@ import Gargantext.API.Admin.Types (HasSettings)
    -- | Represents possible GraphQL queries.
    data Query m
    = Query
    { annuaire_contacts :: GQLA.AnnuaireContactArgs -> m [GQLA.AnnuaireContact]
    , contexts :: GQLCTX.NodeContextArgs -> m [GQLCTX.NodeContextGQL]
    , imt_schools :: GQLIMT.SchoolsArgs -> m [GQLIMT.School]
    , job_logs :: GQLAT.JobLogArgs -> m (Map Int JobLog)
    , nodes :: GQLNode.NodeArgs -> m [GQLNode.Node]
    , node_parent :: GQLNode.NodeParentArgs -> m [GQLNode.Node]
    , user_infos :: GQLUserInfo.UserInfoArgs -> m [GQLUserInfo.UserInfo]
    , users :: GQLUser.UserArgs -> m [GQLUser.User m]
    , tree :: GQLTree.TreeArgs -> m (GQLTree.TreeFirstLevel m)
    , team :: GQLTeam.TeamArgs -> m GQLTeam.Team
    { annuaire_contacts :: GQLA.AnnuaireContactArgs -> m [GQLA.AnnuaireContact]
    , contexts :: GQLCTX.NodeContextArgs -> m [GQLCTX.NodeContextGQL]
    , contexts_for_ngrams :: GQLCTX.ContextsForNgramsArgs -> m [GQLCTX.ContextGQL]
    , imt_schools :: GQLIMT.SchoolsArgs -> m [GQLIMT.School]
    , job_logs :: GQLAT.JobLogArgs -> m (Map Int JobLog)
    , nodes :: GQLNode.NodeArgs -> m [GQLNode.Node]
    , node_parent :: GQLNode.NodeParentArgs -> m [GQLNode.Node]
    , user_infos :: GQLUserInfo.UserInfoArgs -> m [GQLUserInfo.UserInfo]
    , users :: GQLUser.UserArgs -> m [GQLUser.User m]
    , tree :: GQLTree.TreeArgs -> m (GQLTree.TreeFirstLevel m)
    , team :: GQLTeam.TeamArgs -> m GQLTeam.Team
    } deriving (Generic, GQLType)
    data Mutation m
    ......@@ -107,16 +108,17 @@ rootResolver
    => RootResolver (GargM env GargError) e Query Mutation Undefined
    rootResolver =
    RootResolver
    { queryResolver = Query { annuaire_contacts = GQLA.resolveAnnuaireContacts
    , contexts = GQLCTX.resolveNodeContext
    , imt_schools = GQLIMT.resolveSchools
    , job_logs = GQLAT.resolveJobLogs
    , nodes = GQLNode.resolveNodes
    , node_parent = GQLNode.resolveNodeParent
    , user_infos = GQLUserInfo.resolveUserInfos
    , users = GQLUser.resolveUsers
    , tree = GQLTree.resolveTree
    , team = GQLTeam.resolveTeam }
    { queryResolver = Query { annuaire_contacts = GQLA.resolveAnnuaireContacts
    , contexts = GQLCTX.resolveNodeContext
    , contexts_for_ngrams = GQLCTX.resolveContextsForNgrams
    , imt_schools = GQLIMT.resolveSchools
    , job_logs = GQLAT.resolveJobLogs
    , nodes = GQLNode.resolveNodes
    , node_parent = GQLNode.resolveNodeParent
    , user_infos = GQLUserInfo.resolveUserInfos
    , users = GQLUser.resolveUsers
    , tree = GQLTree.resolveTree
    , team = GQLTeam.resolveTeam }
    , mutationResolver = Mutation { update_user_info = GQLUserInfo.updateUserInfo
    , delete_team_membership = GQLTeam.deleteTeamMembership
    , update_node_context_category = GQLCTX.updateNodeContextCategory }
    ......
    src/Gargantext/API/GraphQL/Context.hs
    View file @ 2fd0c7da
    ......@@ -12,33 +12,82 @@ import Data.Morpheus.Types
    , QUERY
    , lift
    )
    import Data.Text (Text, pack)
    import Data.Time (UTCTime)
    import Data.Time.Format.ISO8601 (iso8601Show)
    import Gargantext.API.Admin.Types (HasSettings)
    import Gargantext.API.Prelude (GargM, GargError)
    import Gargantext.Core.Types.Search (HyperdataRow(..), toHyperdataRow)
    import Gargantext.Core.Mail.Types (HasMail)
    import Gargantext.Database.Admin.Types.Node (NodeId(..))
    import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument)
    import Gargantext.Database.Admin.Types.Node (ContextTitle, NodeId(..), NodeTypeId, ParentId, UserId, unNodeId)
    import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
    import Gargantext.Database.Query.Table.NodeContext (getNodeContext)
    import Gargantext.Database.Query.Table.NodeContext (getNodeContext, getContextsForNgrams)
    import qualified Gargantext.Database.Query.Table.NodeContext as DNC
    import Gargantext.Database.Schema.NodeContext (NodeContext, NodeContextPoly(..))
    import Gargantext.Prelude
    import Gargantext.Prelude.Crypto.Hash (Hash)
    import GHC.Generics (Generic)
    data ContextGQL = ContextGQL
    { c_id :: Int
    , c_hash_id :: Maybe Hash
    , c_typename :: NodeTypeId
    , c_user_id :: UserId
    , c_parent_id :: Maybe Int
    , c_name :: ContextTitle
    , c_date :: Text -- TODO UTCTime
    , c_hyperdata :: Maybe HyperdataRowDocumentGQL
    } deriving (Generic, GQLType, Show)
    -- We need this type instead of HyperdataRow(HyperdataRowDocument)
    -- because the latter is a sum type (of doc and contact) and we return
    -- docs here only. Without the union type, GraphQL endpoint is simpler.
    data HyperdataRowDocumentGQL =
    HyperdataRowDocumentGQL { hrd_abstract :: !Text
    , hrd_authors :: !Text
    , hrd_bdd :: !Text
    , hrd_doi :: !Text
    , hrd_institutes :: !Text
    , hrd_language_iso2 :: !Text
    , hrd_page :: !Int
    , hrd_publication_date :: !Text
    , hrd_publication_day :: !Int
    , hrd_publication_hour :: !Int
    , hrd_publication_minute :: !Int
    , hrd_publication_month :: !Int
    , hrd_publication_second :: !Int
    , hrd_publication_year :: !Int
    , hrd_source :: !Text
    , hrd_title :: !Text
    , hrd_url :: !Text
    , hrd_uniqId :: !Text
    , hrd_uniqIdBdd :: !Text
    } deriving (Generic, GQLType, Show)
    data NodeContextGQL = NodeContextGQL
    { nc_id :: Maybe Int
    , nc_node_id :: Int
    , nc_context_id :: Int
    , nc_score :: Maybe Double
    , nc_category :: Maybe Int
    }
    deriving (Generic, GQLType, Show)
    } deriving (Generic, GQLType, Show)
    -- | Arguments to the "context node" query.
    -- "context_id" is doc id
    -- "node_id" is it's corpus id
    data NodeContextArgs
    = NodeContextArgs
    { context_id :: Int
    , node_id :: Int
    } deriving (Generic, GQLType)
    data ContextsForNgramsArgs
    = ContextsForNgramsArgs
    { corpus_id :: Int
    , ngrams_ids :: [Int]
    } deriving (Generic, GQLType)
    data NodeContextCategoryMArgs = NodeContextCategoryMArgs
    { context_id :: Int
    , node_id :: Int
    ......@@ -48,11 +97,22 @@ data NodeContextCategoryMArgs = NodeContextCategoryMArgs
    type GqlM e env = Resolver QUERY e (GargM env GargError)
    type GqlM' e env a = ResolverM e (GargM env GargError) a
    -- GQL API
    -- | Function to resolve context from a query.
    resolveNodeContext
    :: (HasConnectionPool env, HasConfig env, HasMail env)
    => NodeContextArgs -> GqlM e env [NodeContextGQL]
    resolveNodeContext NodeContextArgs { context_id, node_id } = dbNodeContext context_id node_id
    resolveNodeContext NodeContextArgs { context_id, node_id } =
    dbNodeContext context_id node_id
    resolveContextsForNgrams
    :: (HasConnectionPool env, HasConfig env, HasMail env)
    => ContextsForNgramsArgs -> GqlM e env [ContextGQL]
    resolveContextsForNgrams ContextsForNgramsArgs { corpus_id, ngrams_ids } =
    dbContextForNgrams corpus_id ngrams_ids
    -- DB
    -- | Inner function to fetch the node context DB.
    dbNodeContext
    ......@@ -64,7 +124,17 @@ dbNodeContext context_id node_id = do
    -- hyperdata <- getUserHyperdata user_id
    -- lift (map toUser <$> zip user hyperdata)
    c <- lift $ getNodeContext (NodeId context_id) (NodeId node_id)
    pure [toNodeContextGQL c]
    pure $ toNodeContextGQL <$> [c]
    dbContextForNgrams
    :: (HasConnectionPool env, HasConfig env, HasMail env)
    => Int -> [Int] -> GqlM e env [ContextGQL]
    dbContextForNgrams node_id ngrams_ids = do
    contextTuples <- lift $ getContextsForNgrams (NodeId node_id) ngrams_ids
    lift $ printDebug "[dbContextForNgrams] contextTuples" contextTuples
    pure $ toContextGQL <$> contextTuples
    -- Conversion functions
    toNodeContextGQL :: NodeContext -> NodeContextGQL
    toNodeContextGQL (NodeContext { _nc_node_id = NodeId nc_node_id
    ......@@ -76,6 +146,46 @@ toNodeContextGQL (NodeContext { _nc_node_id = NodeId nc_node_id
    , nc_score = _nc_score
    , nc_category = _nc_category }
    toContextGQL :: (NodeId, Maybe Hash, NodeTypeId, UserId, Maybe ParentId, ContextTitle, UTCTime, HyperdataDocument) -> ContextGQL
    toContextGQL ( c_id
    , c_hash_id
    , c_typename
    , c_user_id
    , m_c_parent_id
    , c_name
    , c_date
    , hyperdata ) = ContextGQL { c_id = unNodeId c_id
    , c_parent_id = unNodeId <$> m_c_parent_id
    , c_date = pack $ iso8601Show c_date
    , c_hyperdata = toHyperdataRowDocumentGQL hyperdata
    , .. }
    toHyperdataRowDocumentGQL :: HyperdataDocument -> Maybe HyperdataRowDocumentGQL
    toHyperdataRowDocumentGQL hyperdata =
    case toHyperdataRow hyperdata of
    HyperdataRowDocument { .. } ->
    Just $ HyperdataRowDocumentGQL { hrd_abstract = _hr_abstract
    , hrd_authors = _hr_authors
    , hrd_bdd = _hr_bdd
    , hrd_doi = _hr_doi
    , hrd_institutes = _hr_institutes
    , hrd_language_iso2 = _hr_language_iso2
    , hrd_page = _hr_page
    , hrd_publication_date = _hr_publication_date
    , hrd_publication_day = _hr_publication_day
    , hrd_publication_hour = _hr_publication_hour
    , hrd_publication_minute = _hr_publication_minute
    , hrd_publication_month = _hr_publication_month
    , hrd_publication_second = _hr_publication_second
    , hrd_publication_year = _hr_publication_year
    , hrd_source = _hr_source
    , hrd_title = _hr_title
    , hrd_url = _hr_url
    , hrd_uniqId = _hr_uniqId
    , hrd_uniqIdBdd = _hr_uniqIdBdd
    }
    HyperdataRowContact _ _ _ -> Nothing
    updateNodeContextCategory :: (HasConnectionPool env, HasConfig env, HasMail env, HasSettings env) =>
    NodeContextCategoryMArgs -> GqlM' e env [Int]
    updateNodeContextCategory NodeContextCategoryMArgs { context_id, node_id, category } = do
    ......
    src/Gargantext/API/Search.hs
    View file @ 2fd0c7da
    ......@@ -19,26 +19,21 @@ module Gargantext.API.Search
    import Data.Aeson hiding (defaultTaggedObject)
    -- import Data.List (concat)
    import Data.Maybe (fromMaybe)
    import Data.Swagger hiding (fieldLabelModifier, Contact)
    import Data.Text (Text)
    import Data.Time (UTCTime)
    import GHC.Generics (Generic)
    import Gargantext.API.Prelude (GargServer)
    import Gargantext.Core.Utils.Prefix (unPrefixSwagger, unCapitalize, dropPrefix)
    import Gargantext.Core.Types.Search
    import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
    import Gargantext.Database.Action.Flow.Pairing (isPairedWith)
    import Gargantext.Database.Action.Search
    import Gargantext.Database.Admin.Types.Hyperdata (HyperdataContact(..), HyperdataDocument(..), ContactWho(..))
    import Gargantext.Database.Admin.Types.Hyperdata.Contact (_cw_organization)
    import Gargantext.Database.Admin.Types.Node
    import Gargantext.Database.Query.Facet
    import qualified Gargantext.Defaults as Defaults
    import Gargantext.Prelude
    import Gargantext.Utils.Aeson (defaultTaggedObject)
    import Servant
    import Test.QuickCheck (elements)
    import Test.QuickCheck.Arbitrary
    import qualified Data.Text as Text
    -----------------------------------------------------------------------
    -- TODO-ACCESS: CanSearch? or is it part of CanGetNode
    ......@@ -52,13 +47,11 @@ type API results = Summary "Search endpoint"
    -----------------------------------------------------------------------
    -- | Api search function
    api :: NodeId -> GargServer (API SearchResult)
    api nId (SearchQuery q SearchDoc) o l order =
    SearchResult <$> SearchResultDoc
    <$> map (toRow nId)
    <$> searchInCorpus nId False q o l order
    -- <$> searchInCorpus nId False (concat q) o l order
    api nId (SearchQuery q SearchContact) o l order = do
    printDebug "isPairedWith" nId
    aIds <- isPairedWith nId NodeAnnuaire
    ......@@ -70,7 +63,6 @@ api nId (SearchQuery q SearchContact) o l order = do
    <$> SearchResultContact
    <$> map (toRow aId)
    <$> searchInCorpusWithContacts nId aId q o l order
    api _nId (SearchQuery _q SearchDocWithNgrams) _o _l _order = undefined
    -----------------------------------------------------------------------
    ......@@ -149,136 +141,3 @@ instance ToSchema SearchResultTypes where
    --------------------------------------------------------------------
    data Row =
    Document { id :: !NodeId
    , created :: !UTCTime
    , title :: !Text
    , hyperdata :: !HyperdataRow
    , category :: !Int
    , score :: !Int
    }
    | Contact { c_id :: !Int
    , c_created :: !UTCTime
    , c_hyperdata :: !HyperdataRow
    , c_score :: !Int
    , c_annuaireId :: !NodeId
    }
    deriving (Generic)
    instance FromJSON Row
    where
    parseJSON = genericParseJSON
    ( defaultOptions { sumEncoding = defaultTaggedObject } )
    instance ToJSON Row
    where
    toJSON = genericToJSON (defaultOptions { sumEncoding = defaultTaggedObject })
    instance Arbitrary Row where
    arbitrary = arbitrary
    instance ToSchema Row where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
    class ToRow a where
    toRow :: NodeId -> a -> Row
    instance ToRow FacetDoc where
    toRow _ (FacetDoc { .. }) =
    Document { id = facetDoc_id
    , created = facetDoc_created
    , title = facetDoc_title
    , hyperdata = toHyperdataRow facetDoc_hyperdata
    , category = fromMaybe 0 facetDoc_category
    , score = round $ fromMaybe 0 facetDoc_score }
    -- | TODO rename FacetPaired
    type FacetContact = FacetPaired Int UTCTime HyperdataContact Int
    instance ToRow FacetContact where
    toRow annuaireId (FacetPaired nId utc h s) = Contact nId utc (toHyperdataRow h) s annuaireId
    --------------------------------------------------------------------
    data HyperdataRow =
    HyperdataRowDocument { _hr_abstract :: !Text
    , _hr_authors :: !Text
    , _hr_bdd :: !Text
    , _hr_doi :: !Text
    , _hr_institutes :: !Text
    , _hr_language_iso2 :: !Text
    , _hr_page :: !Int
    , _hr_publication_date :: !Text
    , _hr_publication_day :: !Int
    , _hr_publication_hour :: !Int
    , _hr_publication_minute :: !Int
    , _hr_publication_month :: !Int
    , _hr_publication_second :: !Int
    , _hr_publication_year :: !Int
    , _hr_source :: !Text
    , _hr_title :: !Text
    , _hr_url :: !Text
    , _hr_uniqId :: !Text
    , _hr_uniqIdBdd :: !Text
    }
    | HyperdataRowContact { _hr_firstname :: !Text
    , _hr_lastname :: !Text
    , _hr_labs :: !Text
    }
    deriving (Generic)
    instance FromJSON HyperdataRow
    where
    parseJSON = genericParseJSON
    ( defaultOptions
    { sumEncoding = defaultTaggedObject
    , fieldLabelModifier = unCapitalize . dropPrefix "_hr_"
    , omitNothingFields = False
    }
    )
    instance ToJSON HyperdataRow
    where
    toJSON = genericToJSON
    ( defaultOptions
    { sumEncoding = defaultTaggedObject
    , fieldLabelModifier = unCapitalize . dropPrefix "_hr_"
    , omitNothingFields = False
    }
    )
    instance Arbitrary HyperdataRow where
    arbitrary = arbitrary
    instance ToSchema HyperdataRow where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_hr_")
    class ToHyperdataRow a where
    toHyperdataRow :: a -> HyperdataRow
    instance ToHyperdataRow HyperdataDocument where
    toHyperdataRow (HyperdataDocument { .. }) =
    HyperdataRowDocument
    { _hr_abstract = fromMaybe "" _hd_abstract
    , _hr_authors = fromMaybe "" _hd_authors
    , _hr_bdd = fromMaybe "" _hd_bdd
    , _hr_doi = fromMaybe "" _hd_doi
    , _hr_institutes = fromMaybe "" _hd_institutes
    , _hr_language_iso2 = fromMaybe "EN" _hd_language_iso2
    , _hr_page = fromMaybe 0 _hd_page
    , _hr_publication_date = fromMaybe "" _hd_publication_date
    , _hr_publication_year = fromMaybe (fromIntegral Defaults.year) _hd_publication_year
    , _hr_publication_month = fromMaybe Defaults.month _hd_publication_month
    , _hr_publication_day = fromMaybe Defaults.day _hd_publication_day
    , _hr_publication_hour = fromMaybe 0 _hd_publication_hour
    , _hr_publication_minute = fromMaybe 0 _hd_publication_minute
    , _hr_publication_second = fromMaybe 0 _hd_publication_second
    , _hr_source = fromMaybe "" _hd_source
    , _hr_title = fromMaybe "Title" _hd_title
    , _hr_url = fromMaybe "" _hd_url
    , _hr_uniqId = fromMaybe "" _hd_uniqId
    , _hr_uniqIdBdd = fromMaybe "" _hd_uniqIdBdd }
    instance ToHyperdataRow HyperdataContact where
    toHyperdataRow (HyperdataContact { _hc_who = Just (ContactWho _ fn ln _ _ _), _hc_where = ou} ) =
    HyperdataRowContact (fromMaybe "FirstName" fn) (fromMaybe "LastName" ln) ou'
    where
    ou' = maybe "CNRS" (Text.intercalate " " . _cw_organization) (head ou)
    toHyperdataRow (HyperdataContact {}) =
    HyperdataRowContact "FirstName" "LastName" "Labs"
    src/Gargantext/Core/Types/Search.hs 0 → 100644
    View file @ 2fd0c7da
    {-# LANGUAGE DeriveAnyClass #-}
    module Gargantext.Core.Types.Search where
    import Data.Aeson hiding (defaultTaggedObject)
    import Data.Maybe (fromMaybe)
    import Data.Swagger hiding (fieldLabelModifier, Contact)
    import Data.Text (Text)
    import qualified Data.Text as Text
    import Data.Time (UTCTime)
    import Gargantext.Core.Utils.Prefix (dropPrefix, unCapitalize, unPrefixSwagger)
    import Gargantext.Database.Admin.Types.Hyperdata (ContactWhere(..), HyperdataContact(..), HyperdataDocument(..), ContactWho(..))
    import Gargantext.Database.Admin.Types.Node
    import Gargantext.Database.Query.Facet.Types (Facet(..), FacetDoc, FacetPaired(..))
    import qualified Gargantext.Defaults as Defaults
    import Gargantext.Prelude
    import Gargantext.Utils.Aeson (defaultTaggedObject)
    import GHC.Generics (Generic)
    import Test.QuickCheck.Arbitrary
    data Row =
    Document { id :: !NodeId
    , created :: !UTCTime
    , title :: !Text
    , hyperdata :: !HyperdataRow
    , category :: !Int
    , score :: !Int
    }
    | Contact { c_id :: !Int
    , c_created :: !UTCTime
    , c_hyperdata :: !HyperdataRow
    , c_score :: !Int
    , c_annuaireId :: !NodeId
    }
    deriving (Generic)
    instance FromJSON Row
    where
    parseJSON = genericParseJSON
    ( defaultOptions { sumEncoding = defaultTaggedObject } )
    instance ToJSON Row
    where
    toJSON = genericToJSON (defaultOptions { sumEncoding = defaultTaggedObject })
    instance Arbitrary Row where
    arbitrary = arbitrary
    instance ToSchema Row where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
    class ToRow a where
    toRow :: NodeId -> a -> Row
    instance ToRow FacetDoc where
    toRow _ (FacetDoc { .. }) =
    Document { id = facetDoc_id
    , created = facetDoc_created
    , title = facetDoc_title
    , hyperdata = toHyperdataRow facetDoc_hyperdata
    , category = fromMaybe 0 facetDoc_category
    , score = round $ fromMaybe 0 facetDoc_score }
    -- | TODO rename FacetPaired
    type FacetContact = FacetPaired Int UTCTime HyperdataContact Int
    instance ToRow FacetContact where
    toRow annuaireId (FacetPaired nId utc h s) = Contact nId utc (toHyperdataRow h) s annuaireId
    --------------------------------------------------------------------
    data HyperdataRow =
    HyperdataRowDocument { _hr_abstract :: !Text
    , _hr_authors :: !Text
    , _hr_bdd :: !Text
    , _hr_doi :: !Text
    , _hr_institutes :: !Text
    , _hr_language_iso2 :: !Text
    , _hr_page :: !Int
    , _hr_publication_date :: !Text
    , _hr_publication_day :: !Int
    , _hr_publication_hour :: !Int
    , _hr_publication_minute :: !Int
    , _hr_publication_month :: !Int
    , _hr_publication_second :: !Int
    , _hr_publication_year :: !Int
    , _hr_source :: !Text
    , _hr_title :: !Text
    , _hr_url :: !Text
    , _hr_uniqId :: !Text
    , _hr_uniqIdBdd :: !Text
    }
    | HyperdataRowContact { _hr_firstname :: !Text
    , _hr_lastname :: !Text
    , _hr_labs :: !Text
    }
    deriving (Generic, Show)
    instance FromJSON HyperdataRow
    where
    parseJSON = genericParseJSON
    ( defaultOptions
    { sumEncoding = defaultTaggedObject
    , fieldLabelModifier = unCapitalize . dropPrefix "_hr_"
    , omitNothingFields = False
    }
    )
    instance ToJSON HyperdataRow
    where
    toJSON = genericToJSON
    ( defaultOptions
    { sumEncoding = defaultTaggedObject
    , fieldLabelModifier = unCapitalize . dropPrefix "_hr_"
    , omitNothingFields = False
    }
    )
    instance Arbitrary HyperdataRow where
    arbitrary = arbitrary
    instance ToSchema HyperdataRow where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_hr_")
    class ToHyperdataRow a where
    toHyperdataRow :: a -> HyperdataRow
    instance ToHyperdataRow HyperdataDocument where
    toHyperdataRow (HyperdataDocument { .. }) =
    HyperdataRowDocument
    { _hr_abstract = fromMaybe "" _hd_abstract
    , _hr_authors = fromMaybe "" _hd_authors
    , _hr_bdd = fromMaybe "" _hd_bdd
    , _hr_doi = fromMaybe "" _hd_doi
    , _hr_institutes = fromMaybe "" _hd_institutes
    , _hr_language_iso2 = fromMaybe "EN" _hd_language_iso2
    , _hr_page = fromMaybe 0 _hd_page
    , _hr_publication_date = fromMaybe "" _hd_publication_date
    , _hr_publication_year = fromMaybe (fromIntegral Defaults.year) _hd_publication_year
    , _hr_publication_month = fromMaybe Defaults.month _hd_publication_month
    , _hr_publication_day = fromMaybe Defaults.day _hd_publication_day
    , _hr_publication_hour = fromMaybe 0 _hd_publication_hour
    , _hr_publication_minute = fromMaybe 0 _hd_publication_minute
    , _hr_publication_second = fromMaybe 0 _hd_publication_second
    , _hr_source = fromMaybe "" _hd_source
    , _hr_title = fromMaybe "Title" _hd_title
    , _hr_url = fromMaybe "" _hd_url
    , _hr_uniqId = fromMaybe "" _hd_uniqId
    , _hr_uniqIdBdd = fromMaybe "" _hd_uniqIdBdd }
    instance ToHyperdataRow HyperdataContact where
    toHyperdataRow (HyperdataContact { _hc_who = Just (ContactWho _ fn ln _ _ _), _hc_where = ou} ) =
    HyperdataRowContact (fromMaybe "FirstName" fn) (fromMaybe "LastName" ln) ou'
    where
    ou' = maybe "CNRS" (Text.intercalate " " . _cw_organization) (head ou)
    toHyperdataRow (HyperdataContact {}) =
    HyperdataRowContact "FirstName" "LastName" "Labs"
    src/Gargantext/Database/Admin/Types/Hyperdata.hs
    View file @ 2fd0c7da
    ......@@ -45,5 +45,3 @@ import Gargantext.Database.Admin.Types.Hyperdata.Texts
    import Gargantext.Database.Admin.Types.Hyperdata.Phylo
    import Gargantext.Database.Admin.Types.Hyperdata.User
    import Gargantext.Core.Viz.Graph (HyperdataGraph(..), defaultHyperdataGraph)
    src/Gargantext/Database/Admin/Types/Hyperdata/Document.hs
    View file @ 2fd0c7da
    ......@@ -151,7 +151,7 @@ $(makeLenses ''HyperdataDocumentV3)
    instance FromJSON HyperdataDocument
    where
    parseJSON = genericParseJSON
    ( defaultOptions { sumEncoding = ObjectWithSingleField
    ( defaultOptions { sumEncoding = ObjectWithSingleField
    , fieldLabelModifier = unCapitalize . dropPrefix "_hd_"
    , omitNothingFields = True
    }
    ......@@ -160,7 +160,7 @@ instance FromJSON HyperdataDocument
    instance ToJSON HyperdataDocument
    where
    toJSON = genericToJSON
    ( defaultOptions { sumEncoding = ObjectWithSingleField
    ( defaultOptions { sumEncoding = ObjectWithSingleField
    , fieldLabelModifier = unCapitalize . dropPrefix "_hd_"
    , omitNothingFields = True
    }
    ......
    src/Gargantext/Database/Query/Facet.hs
    View file @ 2fd0c7da
    ......@@ -8,8 +8,6 @@ Stability : experimental
    Portability : POSIX
    -}
    {-# OPTIONS_GHC -fno-warn-orphans #-}
    {-# LANGUAGE Arrows #-}
    {-# LANGUAGE FunctionalDependencies #-}
    {-# LANGUAGE QuasiQuotes #-}
    ......@@ -42,207 +40,27 @@ module Gargantext.Database.Query.Facet
    import Control.Arrow (returnA, (>>>))
    import Control.Lens ((^.))
    import Data.Aeson (FromJSON, ToJSON)
    import Data.Aeson.TH (deriveJSON)
    --import qualified Database.PostgreSQL.Simple as DPS
    --import Database.PostgreSQL.Simple.SqlQQ (sql)
    import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
    import Data.Swagger
    import qualified Data.Text as T
    import Data.Time (UTCTime)
    import Data.Time.Segment (jour)
    import Opaleye
    import Protolude hiding (null, map, sum, not)
    import Servant.API
    import Test.QuickCheck (elements)
    import Test.QuickCheck.Arbitrary
    import qualified Opaleye.Internal.Unpackspec()
    import Gargantext.Core
    import Gargantext.Core.Types
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
    -- import Gargantext.Database.Action.TSQuery (toTSQuery)
    import Gargantext.Database.Admin.Types.Hyperdata
    import Gargantext.Database.Query.Filter
    import Gargantext.Database.Query.Join (leftJoin5)
    import Gargantext.Database.Query.Table.Ngrams
    import Gargantext.Database.Query.Table.Context
    import Gargantext.Database.Schema.Context
    import Gargantext.Database.Query.Table.NodeContext
    import Gargantext.Database.Query.Facet.Types
    import Gargantext.Database.Query.Table.ContextNodeNgrams
    import Gargantext.Database.Query.Table.NodeContext (queryNodeContextTable)
    import Gargantext.Database.Prelude
    import Gargantext.Database.Schema.Context
    import Gargantext.Database.Schema.Node
    import Gargantext.Database.Schema.NodeContext
    import Gargantext.Prelude (printDebug)
    ------------------------------------------------------------------------
    -- | DocFacet
    -- data Facet = FacetDoc | FacetSources | FacetAuthors | FacetTerms
    -- deriving (Show, Generic)
    --instance FromJSON Facet
    --instance ToJSON Facet
    type Category = Int
    type Score = Double
    type Title = Text
    -- TODO remove Title
    type FacetDoc = Facet NodeId UTCTime Title HyperdataDocument (Maybe Category) (Maybe Double) (Maybe Score)
    -- type FacetSources = FacetDoc
    -- type FacetAuthors = FacetDoc
    -- type FacetTerms = FacetDoc
    data Facet id created title hyperdata category ngramCount score =
    FacetDoc { facetDoc_id :: id
    , facetDoc_created :: created
    , facetDoc_title :: title
    , facetDoc_hyperdata :: hyperdata
    , facetDoc_category :: category
    , facetDoc_ngramCount :: ngramCount
    , facetDoc_score :: score
    } deriving (Show, Generic)
    {- | TODO after demo
    data Facet id date hyperdata score =
    FacetDoc { facetDoc_id :: id
    , facetDoc_date :: date
    , facetDoc_hyperdata :: hyperdata
    , facetDoc_score :: score
    } deriving (Show, Generic)
    -}
    data Pair i l = Pair {
    _p_id :: i
    , _p_label :: l
    } deriving (Show, Generic)
    $(deriveJSON (unPrefix "_p_") ''Pair)
    $(makeAdaptorAndInstance "pPair" ''Pair)
    instance (Typeable i, Typeable l, ToSchema i, ToSchema l) => ToSchema (Pair i l) where
    declareNamedSchema = wellNamedSchema "_p_"
    instance (Arbitrary i, Arbitrary l) => Arbitrary (Pair i l) where
    arbitrary = Pair <$> arbitrary <*> arbitrary
    data FacetPaired id date hyperdata score =
    FacetPaired { _fp_id :: id
    , _fp_date :: date
    , _fp_hyperdata :: hyperdata
    , _fp_score :: score }
    deriving (Show, Generic)
    $(deriveJSON (unPrefix "_fp_") ''FacetPaired)
    $(makeAdaptorAndInstance "pFacetPaired" ''FacetPaired)
    instance ( ToSchema id
    , ToSchema date
    , ToSchema hyperdata
    , ToSchema score
    , Typeable id
    , Typeable date
    , Typeable hyperdata
    , Typeable score
    ) => ToSchema (FacetPaired id date hyperdata score) where
    declareNamedSchema = wellNamedSchema "_fp_"
    instance ( Arbitrary id
    , Arbitrary date
    , Arbitrary hyperdata
    , Arbitrary score
    ) => Arbitrary (FacetPaired id date hyperdata score) where
    arbitrary = FacetPaired <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
    type FacetPairedRead = FacetPaired (Column SqlInt4 )
    (Column SqlTimestamptz)
    (Column SqlJsonb )
    (Column SqlInt4 )
    type FacetPairedReadNull = FacetPaired (Column (Nullable SqlInt4) )
    (Column (Nullable SqlTimestamptz))
    (Column (Nullable SqlJsonb) )
    (Column (Nullable SqlInt4) )
    type FacetPairedReadNullAgg = FacetPaired (Aggregator (Column (Nullable SqlInt4) )
    (Column (Nullable SqlInt4) )
    )
    (Aggregator (Column (Nullable SqlTimestamptz))
    (Column (Nullable SqlTimestamptz))
    )
    (Aggregator (Column (Nullable SqlJsonb) )
    (Column (Nullable SqlJsonb) )
    )
    (Aggregator (Column (Nullable SqlInt4) )
    (Column (Nullable SqlInt4) )
    )
    -- | JSON instance
    $(deriveJSON (unPrefix "facetDoc_") ''Facet)
    -- | Documentation instance
    instance ToSchema FacetDoc where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "facetDoc_")
    -- | Mock and Quickcheck instances
    instance Arbitrary FacetDoc where
    arbitrary = elements [ FacetDoc id' (jour year 01 01) t hp (Just cat) (Just ngramCount) (Just score)
    | id' <- [1..10]
    , year <- [1990..2000]
    , t <- ["title", "another title"]
    , hp <- arbitraryHyperdataDocuments
    , cat <- [0..2]
    , ngramCount <- [3..100]
    , score <- [3..100]
    ]
    -- Facets / Views for the Front End
    -- | Database instances
    $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
    -- $(makeLensesWith abbreviatedFields ''Facet)
    type FacetDocRead = Facet (Column SqlInt4 )
    (Column SqlTimestamptz)
    (Column SqlText )
    (Column SqlJsonb )
    (Column (Nullable SqlInt4)) -- Category
    (Column (Nullable SqlFloat8)) -- Ngrams Count
    (Column (Nullable SqlFloat8)) -- Score
    -----------------------------------------------------------------------
    -----------------------------------------------------------------------
    data OrderBy = DateAsc | DateDesc
    | TitleAsc | TitleDesc
    | ScoreDesc | ScoreAsc
    | SourceAsc | SourceDesc
    | TagAsc | TagDesc
    deriving (Generic, Enum, Bounded, Read, Show)
    instance FromHttpApiData OrderBy
    where
    parseUrlPiece "DateAsc" = pure DateAsc
    parseUrlPiece "DateDesc" = pure DateDesc
    parseUrlPiece "TitleAsc" = pure TitleAsc
    parseUrlPiece "TitleDesc" = pure TitleDesc
    parseUrlPiece "ScoreAsc" = pure ScoreAsc
    parseUrlPiece "ScoreDesc" = pure ScoreDesc
    parseUrlPiece "SourceAsc" = pure SourceAsc
    parseUrlPiece "SourceDesc" = pure SourceDesc
    parseUrlPiece "TagAsc" = pure TagAsc
    parseUrlPiece "TagDesc" = pure TagDesc
    parseUrlPiece _ = Left "Unexpected value of OrderBy"
    instance ToHttpApiData OrderBy where
    toUrlPiece = T.pack . show
    instance ToParamSchema OrderBy
    instance FromJSON OrderBy
    instance ToJSON OrderBy
    instance ToSchema OrderBy
    instance Arbitrary OrderBy
    where
    arbitrary = elements [minBound..maxBound]
    -- TODO-SECURITY check
    ......
    src/Gargantext/Database/Query/Facet/Types.hs 0 → 100644
    View file @ 2fd0c7da
    {-# LANGUAGE TemplateHaskell #-}
    module Gargantext.Database.Query.Facet.Types where
    import Data.Aeson (FromJSON, ToJSON)
    import Data.Aeson.TH (deriveJSON)
    import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
    import Data.Swagger
    import qualified Data.Text as T
    import Data.Time (UTCTime)
    import Data.Time.Segment (jour)
    import Gargantext.Core.Types
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
    import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument, arbitraryHyperdataDocuments)
    import Opaleye
    import Protolude hiding (null, map, sum, not)
    import Servant.API (FromHttpApiData(..), ToHttpApiData(..))
    import Test.QuickCheck (elements)
    import Test.QuickCheck.Arbitrary
    -- | DocFacet
    -- data Facet = FacetDoc | FacetSources | FacetAuthors | FacetTerms
    -- deriving (Show, Generic)
    --instance FromJSON Facet
    --instance ToJSON Facet
    type Category = Int
    type Score = Double
    type Title = Text
    -- TODO remove Title
    type FacetDoc = Facet NodeId UTCTime Title HyperdataDocument (Maybe Category) (Maybe Double) (Maybe Score)
    -- type FacetSources = FacetDoc
    -- type FacetAuthors = FacetDoc
    -- type FacetTerms = FacetDoc
    data Facet id created title hyperdata category ngramCount score =
    FacetDoc { facetDoc_id :: id
    , facetDoc_created :: created
    , facetDoc_title :: title
    , facetDoc_hyperdata :: hyperdata
    , facetDoc_category :: category
    , facetDoc_ngramCount :: ngramCount
    , facetDoc_score :: score
    } deriving (Show, Generic)
    {- | TODO after demo
    data Facet id date hyperdata score =
    FacetDoc { facetDoc_id :: id
    , facetDoc_date :: date
    , facetDoc_hyperdata :: hyperdata
    , facetDoc_score :: score
    } deriving (Show, Generic)
    -}
    data Pair i l = Pair {
    _p_id :: i
    , _p_label :: l
    } deriving (Show, Generic)
    $(deriveJSON (unPrefix "_p_") ''Pair)
    $(makeAdaptorAndInstance "pPair" ''Pair)
    instance (Typeable i, Typeable l, ToSchema i, ToSchema l) => ToSchema (Pair i l) where
    declareNamedSchema = wellNamedSchema "_p_"
    instance (Arbitrary i, Arbitrary l) => Arbitrary (Pair i l) where
    arbitrary = Pair <$> arbitrary <*> arbitrary
    data FacetPaired id date hyperdata score =
    FacetPaired { _fp_id :: id
    , _fp_date :: date
    , _fp_hyperdata :: hyperdata
    , _fp_score :: score }
    deriving (Show, Generic)
    $(deriveJSON (unPrefix "_fp_") ''FacetPaired)
    $(makeAdaptorAndInstance "pFacetPaired" ''FacetPaired)
    instance ( ToSchema id
    , ToSchema date
    , ToSchema hyperdata
    , ToSchema score
    , Typeable id
    , Typeable date
    , Typeable hyperdata
    , Typeable score
    ) => ToSchema (FacetPaired id date hyperdata score) where
    declareNamedSchema = wellNamedSchema "_fp_"
    instance ( Arbitrary id
    , Arbitrary date
    , Arbitrary hyperdata
    , Arbitrary score
    ) => Arbitrary (FacetPaired id date hyperdata score) where
    arbitrary = FacetPaired <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
    type FacetPairedRead = FacetPaired (Column SqlInt4 )
    (Column SqlTimestamptz)
    (Column SqlJsonb )
    (Column SqlInt4 )
    type FacetPairedReadNull = FacetPaired (Column (Nullable SqlInt4) )
    (Column (Nullable SqlTimestamptz))
    (Column (Nullable SqlJsonb) )
    (Column (Nullable SqlInt4) )
    type FacetPairedReadNullAgg = FacetPaired (Aggregator (Column (Nullable SqlInt4) )
    (Column (Nullable SqlInt4) )
    )
    (Aggregator (Column (Nullable SqlTimestamptz))
    (Column (Nullable SqlTimestamptz))
    )
    (Aggregator (Column (Nullable SqlJsonb) )
    (Column (Nullable SqlJsonb) )
    )
    (Aggregator (Column (Nullable SqlInt4) )
    (Column (Nullable SqlInt4) )
    )
    -- | JSON instance
    $(deriveJSON (unPrefix "facetDoc_") ''Facet)
    -- | Documentation instance
    instance ToSchema FacetDoc where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "facetDoc_")
    -- | Mock and Quickcheck instances
    instance Arbitrary FacetDoc where
    arbitrary = elements [ FacetDoc id' (jour year 01 01) t hp (Just cat) (Just ngramCount) (Just score)
    | id' <- [1..10]
    , year <- [1990..2000]
    , t <- ["title", "another title"]
    , hp <- arbitraryHyperdataDocuments
    , cat <- [0..2]
    , ngramCount <- [3..100]
    , score <- [3..100]
    ]
    -- Facets / Views for the Front End
    -- | Database instances
    $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
    -- $(makeLensesWith abbreviatedFields ''Facet)
    type FacetDocRead = Facet (Column SqlInt4 )
    (Column SqlTimestamptz)
    (Column SqlText )
    (Column SqlJsonb )
    (Column (Nullable SqlInt4)) -- Category
    (Column (Nullable SqlFloat8)) -- Ngrams Count
    (Column (Nullable SqlFloat8)) -- Score
    -----------------------------------------------------------------------
    -----------------------------------------------------------------------
    data OrderBy = DateAsc | DateDesc
    | TitleAsc | TitleDesc
    | ScoreDesc | ScoreAsc
    | SourceAsc | SourceDesc
    | TagAsc | TagDesc
    deriving (Generic, Enum, Bounded, Read, Show)
    instance FromHttpApiData OrderBy
    where
    parseUrlPiece "DateAsc" = pure DateAsc
    parseUrlPiece "DateDesc" = pure DateDesc
    parseUrlPiece "TitleAsc" = pure TitleAsc
    parseUrlPiece "TitleDesc" = pure TitleDesc
    parseUrlPiece "ScoreAsc" = pure ScoreAsc
    parseUrlPiece "ScoreDesc" = pure ScoreDesc
    parseUrlPiece "SourceAsc" = pure SourceAsc
    parseUrlPiece "SourceDesc" = pure SourceDesc
    parseUrlPiece "TagAsc" = pure TagAsc
    parseUrlPiece "TagDesc" = pure TagDesc
    parseUrlPiece _ = Left "Unexpected value of OrderBy"
    instance ToHttpApiData OrderBy where
    toUrlPiece = T.pack . show
    instance ToParamSchema OrderBy
    instance FromJSON OrderBy
    instance ToJSON OrderBy
    instance ToSchema OrderBy
    instance Arbitrary OrderBy
    where
    arbitrary = elements [minBound..maxBound]
    src/Gargantext/Database/Query/Table/NodeContext.hs
    View file @ 2fd0c7da
    {-|
    Module : Gargantext.Database.Query.Table.NodeNode
    Module : Gargantext.Database.Query.Table.NodeContext
    Description :
    Copyright : (c) CNRS, 2017-Present
    License : AGPL + CECILL v3
    ......@@ -29,6 +29,7 @@ module Gargantext.Database.Query.Table.NodeContext
    , getNodeContexts
    , getNodeContext
    , updateNodeContextCategory
    , getContextsForNgrams
    , insertNodeContext
    , deleteNodeContext
    , selectPublicContexts
    ......@@ -39,18 +40,21 @@ module Gargantext.Database.Query.Table.NodeContext
    import Control.Arrow (returnA)
    import Control.Lens (view, (^.))
    import Data.Maybe (catMaybes)
    import Data.Time (UTCTime)
    import Data.Text (Text, splitOn)
    import Database.PostgreSQL.Simple.SqlQQ (sql)
    import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
    import Opaleye
    import qualified Database.PostgreSQL.Simple as PGS (Query, Only(..))
    import qualified Database.PostgreSQL.Simple as PGS (In(..), Query, Only(..))
    import qualified Opaleye as O
    import Gargantext.Core
    import Gargantext.Core.Types
    -- import Gargantext.Core.Types.Search (HyperdataRow(..), toHyperdataRow)
    import Gargantext.Database.Admin.Types.Hyperdata
    import Gargantext.Database.Query.Table.Node.Error (HasNodeError, NodeError(DoesNotExist), nodeError)
    import Gargantext.Database.Prelude
    import Gargantext.Prelude.Crypto.Hash (Hash)
    import Gargantext.Database.Schema.Context
    import Gargantext.Database.Schema.Node
    import Gargantext.Database.Schema.NodeContext
    ......@@ -77,7 +81,7 @@ getNodeContexts n = runOpaQuery (selectNodeContexts $ pgNodeId n)
    getNodeContext :: HasNodeError err => ContextId -> NodeId -> Cmd err NodeContext
    getNodeContext c n = do
    maybeNodeContext <- headMay <$> runOpaQuery (selectNodeContext (pgNodeId c) (pgNodeId n))
    maybeNodeContext <- headMay <$> runOpaQuery (selectNodeContext (pgNodeId c) (pgNodeId n))
    case maybeNodeContext of
    Nothing -> nodeError (DoesNotExist c)
    Just r -> pure r
    ......@@ -99,6 +103,17 @@ updateNodeContextCategory cId nId cat = do
    WHERE context_id = ?
    AND node_id = ? |]
    getContextsForNgrams :: HasNodeError err => NodeId -> [Int] -> Cmd err [(NodeId, Maybe Hash, NodeTypeId, UserId, Maybe ParentId, ContextTitle, UTCTime, HyperdataDocument)]
    getContextsForNgrams cId ngramsIds = runPGSQuery query (cId, PGS.In ngramsIds)
    where
    query :: PGS.Query
    query = [sql| SELECT contexts.id, hash_id, typename, user_id, parent_id, name, date, hyperdata
    FROM contexts
    JOIN context_node_ngrams ON contexts.id = context_node_ngrams.context_id
    JOIN nodes_contexts ON contexts.id = nodes_contexts.context_id
    WHERE nodes_contexts.node_id = ?
    AND context_node_ngrams.ngrams_id IN ? |]
    ------------------------------------------------------------------------
    insertNodeContext :: [NodeContext] -> Cmd err Int
    insertNodeContext ns = mkCmd $ \conn -> fromIntegral <$> (runInsert_ conn
    ......
    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