Skip to content

haskell-gargantext
haskell-gargantext
Commit d741e8c4 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

Merge remote-tracking branch 'origin/dev-hackathon-fixes' into dev

parents 05aa91b6 2fd0c7da
Hide whitespace changes
Inline Side-by-side
Showing with 509 additions and 362 deletions
gargantext.cabal
View file @ d741e8c4
......@@ -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 @ d741e8c4
......@@ -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 @ d741e8c4
......@@ -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 @ d741e8c4
......@@ -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 @ d741e8c4
{-# 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 @ d741e8c4
......@@ -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 @ d741e8c4
......@@ -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 @ d741e8c4
......@@ -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 @ d741e8c4
{-# 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 @ d741e8c4
{-|
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