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
Hide whitespace changes
Inline Side-by-side
Showing with 509 additions and 362 deletions
gargantext.cabal
View file @ 2fd0c7da
...@@ -223,6 +223,7 @@ library ...@@ -223,6 +223,7 @@ library
Gargantext.Core.Text.Terms.Multi.PosTagging Gargantext.Core.Text.Terms.Multi.PosTagging
Gargantext.Core.Text.Terms.Multi.PosTagging.Types Gargantext.Core.Text.Terms.Multi.PosTagging.Types
Gargantext.Core.Types.Phylo Gargantext.Core.Types.Phylo
Gargantext.Core.Types.Search
Gargantext.Core.Utils.DateUtils Gargantext.Core.Utils.DateUtils
Gargantext.Core.Viz Gargantext.Core.Viz
Gargantext.Core.Viz.Chart Gargantext.Core.Viz.Chart
...@@ -282,6 +283,7 @@ library ...@@ -282,6 +283,7 @@ library
Gargantext.Database.GargDB Gargantext.Database.GargDB
Gargantext.Database.Query Gargantext.Database.Query
Gargantext.Database.Query.Facet Gargantext.Database.Query.Facet
Gargantext.Database.Query.Facet.Types
Gargantext.Database.Query.Filter Gargantext.Database.Query.Filter
Gargantext.Database.Query.Join Gargantext.Database.Query.Join
Gargantext.Database.Query.Prelude Gargantext.Database.Query.Prelude
......
src/Gargantext/API/GraphQL.hs
View file @ 2fd0c7da
...@@ -66,16 +66,17 @@ import Gargantext.API.Admin.Types (HasSettings) ...@@ -66,16 +66,17 @@ import Gargantext.API.Admin.Types (HasSettings)
-- | Represents possible GraphQL queries. -- | Represents possible GraphQL queries.
data Query m data Query m
= Query = Query
{ annuaire_contacts :: GQLA.AnnuaireContactArgs -> m [GQLA.AnnuaireContact] { annuaire_contacts :: GQLA.AnnuaireContactArgs -> m [GQLA.AnnuaireContact]
, contexts :: GQLCTX.NodeContextArgs -> m [GQLCTX.NodeContextGQL] , contexts :: GQLCTX.NodeContextArgs -> m [GQLCTX.NodeContextGQL]
, imt_schools :: GQLIMT.SchoolsArgs -> m [GQLIMT.School] , contexts_for_ngrams :: GQLCTX.ContextsForNgramsArgs -> m [GQLCTX.ContextGQL]
, job_logs :: GQLAT.JobLogArgs -> m (Map Int JobLog) , imt_schools :: GQLIMT.SchoolsArgs -> m [GQLIMT.School]
, nodes :: GQLNode.NodeArgs -> m [GQLNode.Node] , job_logs :: GQLAT.JobLogArgs -> m (Map Int JobLog)
, node_parent :: GQLNode.NodeParentArgs -> m [GQLNode.Node] , nodes :: GQLNode.NodeArgs -> m [GQLNode.Node]
, user_infos :: GQLUserInfo.UserInfoArgs -> m [GQLUserInfo.UserInfo] , node_parent :: GQLNode.NodeParentArgs -> m [GQLNode.Node]
, users :: GQLUser.UserArgs -> m [GQLUser.User m] , user_infos :: GQLUserInfo.UserInfoArgs -> m [GQLUserInfo.UserInfo]
, tree :: GQLTree.TreeArgs -> m (GQLTree.TreeFirstLevel m) , users :: GQLUser.UserArgs -> m [GQLUser.User m]
, team :: GQLTeam.TeamArgs -> m GQLTeam.Team , tree :: GQLTree.TreeArgs -> m (GQLTree.TreeFirstLevel m)
, team :: GQLTeam.TeamArgs -> m GQLTeam.Team
} deriving (Generic, GQLType) } deriving (Generic, GQLType)
data Mutation m data Mutation m
...@@ -107,16 +108,17 @@ rootResolver ...@@ -107,16 +108,17 @@ rootResolver
=> RootResolver (GargM env GargError) e Query Mutation Undefined => RootResolver (GargM env GargError) e Query Mutation Undefined
rootResolver = rootResolver =
RootResolver RootResolver
{ queryResolver = Query { annuaire_contacts = GQLA.resolveAnnuaireContacts { queryResolver = Query { annuaire_contacts = GQLA.resolveAnnuaireContacts
, contexts = GQLCTX.resolveNodeContext , contexts = GQLCTX.resolveNodeContext
, imt_schools = GQLIMT.resolveSchools , contexts_for_ngrams = GQLCTX.resolveContextsForNgrams
, job_logs = GQLAT.resolveJobLogs , imt_schools = GQLIMT.resolveSchools
, nodes = GQLNode.resolveNodes , job_logs = GQLAT.resolveJobLogs
, node_parent = GQLNode.resolveNodeParent , nodes = GQLNode.resolveNodes
, user_infos = GQLUserInfo.resolveUserInfos , node_parent = GQLNode.resolveNodeParent
, users = GQLUser.resolveUsers , user_infos = GQLUserInfo.resolveUserInfos
, tree = GQLTree.resolveTree , users = GQLUser.resolveUsers
, team = GQLTeam.resolveTeam } , tree = GQLTree.resolveTree
, team = GQLTeam.resolveTeam }
, mutationResolver = Mutation { update_user_info = GQLUserInfo.updateUserInfo , mutationResolver = Mutation { update_user_info = GQLUserInfo.updateUserInfo
, delete_team_membership = GQLTeam.deleteTeamMembership , delete_team_membership = GQLTeam.deleteTeamMembership
, update_node_context_category = GQLCTX.updateNodeContextCategory } , update_node_context_category = GQLCTX.updateNodeContextCategory }
......
src/Gargantext/API/GraphQL/Context.hs
View file @ 2fd0c7da
...@@ -12,33 +12,82 @@ import Data.Morpheus.Types ...@@ -12,33 +12,82 @@ import Data.Morpheus.Types
, QUERY , QUERY
, lift , 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.Admin.Types (HasSettings)
import Gargantext.API.Prelude (GargM, GargError) import Gargantext.API.Prelude (GargM, GargError)
import Gargantext.Core.Types.Search (HyperdataRow(..), toHyperdataRow)
import Gargantext.Core.Mail.Types (HasMail) 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.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 qualified Gargantext.Database.Query.Table.NodeContext as DNC
import Gargantext.Database.Schema.NodeContext (NodeContext, NodeContextPoly(..)) import Gargantext.Database.Schema.NodeContext (NodeContext, NodeContextPoly(..))
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Prelude.Crypto.Hash (Hash)
import GHC.Generics (Generic) 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 data NodeContextGQL = NodeContextGQL
{ nc_id :: Maybe Int { nc_id :: Maybe Int
, nc_node_id :: Int , nc_node_id :: Int
, nc_context_id :: Int , nc_context_id :: Int
, nc_score :: Maybe Double , nc_score :: Maybe Double
, nc_category :: Maybe Int , nc_category :: Maybe Int
} } deriving (Generic, GQLType, Show)
deriving (Generic, GQLType, Show)
-- | Arguments to the "context node" query. -- | Arguments to the "context node" query.
-- "context_id" is doc id
-- "node_id" is it's corpus id
data NodeContextArgs data NodeContextArgs
= NodeContextArgs = NodeContextArgs
{ context_id :: Int { context_id :: Int
, node_id :: Int , node_id :: Int
} deriving (Generic, GQLType) } deriving (Generic, GQLType)
data ContextsForNgramsArgs
= ContextsForNgramsArgs
{ corpus_id :: Int
, ngrams_ids :: [Int]
} deriving (Generic, GQLType)
data NodeContextCategoryMArgs = NodeContextCategoryMArgs data NodeContextCategoryMArgs = NodeContextCategoryMArgs
{ context_id :: Int { context_id :: Int
, node_id :: Int , node_id :: Int
...@@ -48,11 +97,22 @@ data NodeContextCategoryMArgs = NodeContextCategoryMArgs ...@@ -48,11 +97,22 @@ data NodeContextCategoryMArgs = NodeContextCategoryMArgs
type GqlM e env = Resolver QUERY e (GargM env GargError) type GqlM e env = Resolver QUERY e (GargM env GargError)
type GqlM' e env a = ResolverM e (GargM env GargError) a type GqlM' e env a = ResolverM e (GargM env GargError) a
-- GQL API
-- | Function to resolve context from a query. -- | Function to resolve context from a query.
resolveNodeContext resolveNodeContext
:: (HasConnectionPool env, HasConfig env, HasMail env) :: (HasConnectionPool env, HasConfig env, HasMail env)
=> NodeContextArgs -> GqlM e env [NodeContextGQL] => 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. -- | Inner function to fetch the node context DB.
dbNodeContext dbNodeContext
...@@ -64,7 +124,17 @@ dbNodeContext context_id node_id = do ...@@ -64,7 +124,17 @@ dbNodeContext context_id node_id = do
-- hyperdata <- getUserHyperdata user_id -- hyperdata <- getUserHyperdata user_id
-- lift (map toUser <$> zip user hyperdata) -- lift (map toUser <$> zip user hyperdata)
c <- lift $ getNodeContext (NodeId context_id) (NodeId node_id) 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 -> NodeContextGQL
toNodeContextGQL (NodeContext { _nc_node_id = NodeId nc_node_id toNodeContextGQL (NodeContext { _nc_node_id = NodeId nc_node_id
...@@ -76,6 +146,46 @@ 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_score = _nc_score
, nc_category = _nc_category } , 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) => updateNodeContextCategory :: (HasConnectionPool env, HasConfig env, HasMail env, HasSettings env) =>
NodeContextCategoryMArgs -> GqlM' e env [Int] NodeContextCategoryMArgs -> GqlM' e env [Int]
updateNodeContextCategory NodeContextCategoryMArgs { context_id, node_id, category } = do updateNodeContextCategory NodeContextCategoryMArgs { context_id, node_id, category } = do
......
src/Gargantext/API/Search.hs
View file @ 2fd0c7da
...@@ -19,26 +19,21 @@ module Gargantext.API.Search ...@@ -19,26 +19,21 @@ module Gargantext.API.Search
import Data.Aeson hiding (defaultTaggedObject) import Data.Aeson hiding (defaultTaggedObject)
-- import Data.List (concat) -- import Data.List (concat)
import Data.Maybe (fromMaybe)
import Data.Swagger hiding (fieldLabelModifier, Contact) import Data.Swagger hiding (fieldLabelModifier, Contact)
import Data.Text (Text) import Data.Text (Text)
import Data.Time (UTCTime)
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Gargantext.API.Prelude (GargServer) 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.Flow.Pairing (isPairedWith)
import Gargantext.Database.Action.Search 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.Admin.Types.Node
import Gargantext.Database.Query.Facet import Gargantext.Database.Query.Facet
import qualified Gargantext.Defaults as Defaults
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Utils.Aeson (defaultTaggedObject) import Gargantext.Utils.Aeson (defaultTaggedObject)
import Servant import Servant
import Test.QuickCheck (elements) import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary import Test.QuickCheck.Arbitrary
import qualified Data.Text as Text
----------------------------------------------------------------------- -----------------------------------------------------------------------
-- TODO-ACCESS: CanSearch? or is it part of CanGetNode -- TODO-ACCESS: CanSearch? or is it part of CanGetNode
...@@ -52,13 +47,11 @@ type API results = Summary "Search endpoint" ...@@ -52,13 +47,11 @@ type API results = Summary "Search endpoint"
----------------------------------------------------------------------- -----------------------------------------------------------------------
-- | Api search function -- | Api search function
api :: NodeId -> GargServer (API SearchResult) api :: NodeId -> GargServer (API SearchResult)
api nId (SearchQuery q SearchDoc) o l order = api nId (SearchQuery q SearchDoc) o l order =
SearchResult <$> SearchResultDoc SearchResult <$> SearchResultDoc
<$> map (toRow nId) <$> map (toRow nId)
<$> searchInCorpus nId False q o l order <$> searchInCorpus nId False q o l order
-- <$> searchInCorpus nId False (concat q) o l order -- <$> searchInCorpus nId False (concat q) o l order
api nId (SearchQuery q SearchContact) o l order = do api nId (SearchQuery q SearchContact) o l order = do
printDebug "isPairedWith" nId printDebug "isPairedWith" nId
aIds <- isPairedWith nId NodeAnnuaire aIds <- isPairedWith nId NodeAnnuaire
...@@ -70,7 +63,6 @@ api nId (SearchQuery q SearchContact) o l order = do ...@@ -70,7 +63,6 @@ api nId (SearchQuery q SearchContact) o l order = do
<$> SearchResultContact <$> SearchResultContact
<$> map (toRow aId) <$> map (toRow aId)
<$> searchInCorpusWithContacts nId aId q o l order <$> searchInCorpusWithContacts nId aId q o l order
api _nId (SearchQuery _q SearchDocWithNgrams) _o _l _order = undefined api _nId (SearchQuery _q SearchDocWithNgrams) _o _l _order = undefined
----------------------------------------------------------------------- -----------------------------------------------------------------------
...@@ -149,136 +141,3 @@ instance ToSchema SearchResultTypes where ...@@ -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 ...@@ -45,5 +45,3 @@ import Gargantext.Database.Admin.Types.Hyperdata.Texts
import Gargantext.Database.Admin.Types.Hyperdata.Phylo import Gargantext.Database.Admin.Types.Hyperdata.Phylo
import Gargantext.Database.Admin.Types.Hyperdata.User import Gargantext.Database.Admin.Types.Hyperdata.User
import Gargantext.Core.Viz.Graph (HyperdataGraph(..), defaultHyperdataGraph) import Gargantext.Core.Viz.Graph (HyperdataGraph(..), defaultHyperdataGraph)
src/Gargantext/Database/Admin/Types/Hyperdata/Document.hs
View file @ 2fd0c7da
...@@ -151,7 +151,7 @@ $(makeLenses ''HyperdataDocumentV3) ...@@ -151,7 +151,7 @@ $(makeLenses ''HyperdataDocumentV3)
instance FromJSON HyperdataDocument instance FromJSON HyperdataDocument
where where
parseJSON = genericParseJSON parseJSON = genericParseJSON
( defaultOptions { sumEncoding = ObjectWithSingleField ( defaultOptions { sumEncoding = ObjectWithSingleField
, fieldLabelModifier = unCapitalize . dropPrefix "_hd_" , fieldLabelModifier = unCapitalize . dropPrefix "_hd_"
, omitNothingFields = True , omitNothingFields = True
} }
...@@ -160,7 +160,7 @@ instance FromJSON HyperdataDocument ...@@ -160,7 +160,7 @@ instance FromJSON HyperdataDocument
instance ToJSON HyperdataDocument instance ToJSON HyperdataDocument
where where
toJSON = genericToJSON toJSON = genericToJSON
( defaultOptions { sumEncoding = ObjectWithSingleField ( defaultOptions { sumEncoding = ObjectWithSingleField
, fieldLabelModifier = unCapitalize . dropPrefix "_hd_" , fieldLabelModifier = unCapitalize . dropPrefix "_hd_"
, omitNothingFields = True , omitNothingFields = True
} }
......
src/Gargantext/Database/Query/Facet.hs
View file @ 2fd0c7da
...@@ -8,8 +8,6 @@ Stability : experimental ...@@ -8,8 +8,6 @@ Stability : experimental
Portability : POSIX Portability : POSIX
-} -}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-} {-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
...@@ -42,207 +40,27 @@ module Gargantext.Database.Query.Facet ...@@ -42,207 +40,27 @@ module Gargantext.Database.Query.Facet
import Control.Arrow (returnA, (>>>)) import Control.Arrow (returnA, (>>>))
import Control.Lens ((^.)) 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 qualified Data.Text as T
import Data.Time (UTCTime)
import Data.Time.Segment (jour)
import Opaleye import Opaleye
import Protolude hiding (null, map, sum, not) import Protolude hiding (null, map, sum, not)
import Servant.API
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary
import qualified Opaleye.Internal.Unpackspec() import qualified Opaleye.Internal.Unpackspec()
import Gargantext.Core import Gargantext.Core
import Gargantext.Core.Types 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.Filter
import Gargantext.Database.Query.Join (leftJoin5) import Gargantext.Database.Query.Join (leftJoin5)
import Gargantext.Database.Query.Table.Ngrams import Gargantext.Database.Query.Table.Ngrams
import Gargantext.Database.Query.Table.Context import Gargantext.Database.Query.Table.Context
import Gargantext.Database.Schema.Context import Gargantext.Database.Query.Facet.Types
import Gargantext.Database.Query.Table.NodeContext
import Gargantext.Database.Query.Table.ContextNodeNgrams import Gargantext.Database.Query.Table.ContextNodeNgrams
import Gargantext.Database.Query.Table.NodeContext (queryNodeContextTable)
import Gargantext.Database.Prelude import Gargantext.Database.Prelude
import Gargantext.Database.Schema.Context
import Gargantext.Database.Schema.Node import Gargantext.Database.Schema.Node
import Gargantext.Database.Schema.NodeContext
import Gargantext.Prelude (printDebug) 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 -- 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 : Description :
Copyright : (c) CNRS, 2017-Present Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3 License : AGPL + CECILL v3
...@@ -29,6 +29,7 @@ module Gargantext.Database.Query.Table.NodeContext ...@@ -29,6 +29,7 @@ module Gargantext.Database.Query.Table.NodeContext
, getNodeContexts , getNodeContexts
, getNodeContext , getNodeContext
, updateNodeContextCategory , updateNodeContextCategory
, getContextsForNgrams
, insertNodeContext , insertNodeContext
, deleteNodeContext , deleteNodeContext
, selectPublicContexts , selectPublicContexts
...@@ -39,18 +40,21 @@ module Gargantext.Database.Query.Table.NodeContext ...@@ -39,18 +40,21 @@ module Gargantext.Database.Query.Table.NodeContext
import Control.Arrow (returnA) import Control.Arrow (returnA)
import Control.Lens (view, (^.)) import Control.Lens (view, (^.))
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
import Data.Time (UTCTime)
import Data.Text (Text, splitOn) import Data.Text (Text, splitOn)
import Database.PostgreSQL.Simple.SqlQQ (sql) import Database.PostgreSQL.Simple.SqlQQ (sql)
import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..)) import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import Opaleye 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 qualified Opaleye as O
import Gargantext.Core import Gargantext.Core
import Gargantext.Core.Types import Gargantext.Core.Types
-- import Gargantext.Core.Types.Search (HyperdataRow(..), toHyperdataRow)
import Gargantext.Database.Admin.Types.Hyperdata import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Query.Table.Node.Error (HasNodeError, NodeError(DoesNotExist), nodeError) import Gargantext.Database.Query.Table.Node.Error (HasNodeError, NodeError(DoesNotExist), nodeError)
import Gargantext.Database.Prelude import Gargantext.Database.Prelude
import Gargantext.Prelude.Crypto.Hash (Hash)
import Gargantext.Database.Schema.Context import Gargantext.Database.Schema.Context
import Gargantext.Database.Schema.Node import Gargantext.Database.Schema.Node
import Gargantext.Database.Schema.NodeContext import Gargantext.Database.Schema.NodeContext
...@@ -77,7 +81,7 @@ getNodeContexts n = runOpaQuery (selectNodeContexts $ pgNodeId n) ...@@ -77,7 +81,7 @@ getNodeContexts n = runOpaQuery (selectNodeContexts $ pgNodeId n)
getNodeContext :: HasNodeError err => ContextId -> NodeId -> Cmd err NodeContext getNodeContext :: HasNodeError err => ContextId -> NodeId -> Cmd err NodeContext
getNodeContext c n = do getNodeContext c n = do
maybeNodeContext <- headMay <$> runOpaQuery (selectNodeContext (pgNodeId c) (pgNodeId n)) maybeNodeContext <- headMay <$> runOpaQuery (selectNodeContext (pgNodeId c) (pgNodeId n))
case maybeNodeContext of case maybeNodeContext of
Nothing -> nodeError (DoesNotExist c) Nothing -> nodeError (DoesNotExist c)
Just r -> pure r Just r -> pure r
...@@ -99,6 +103,17 @@ updateNodeContextCategory cId nId cat = do ...@@ -99,6 +103,17 @@ updateNodeContextCategory cId nId cat = do
WHERE context_id = ? WHERE context_id = ?
AND node_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 :: [NodeContext] -> Cmd err Int
insertNodeContext ns = mkCmd $ \conn -> fromIntegral <$> (runInsert_ conn 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