-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
module Gargantext.Database.Query.Facet
( runViewAuthorsDoc
, runViewDocuments
+ , runCountDocuments
, filterWith
+ , Category
+ , Score
+ , Title
+
, Pair(..)
, Facet(..)
, FacetDoc
, FacetDocRead
, FacetPaired(..)
, FacetPairedRead
+ , FacetPairedReadNull
+ , FacetPairedReadNullAgg
, OrderBy(..)
)
where
import Control.Lens ((^.))
import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson.TH (deriveJSON)
-import Data.Either(Either(Left))
-import Data.Maybe (Maybe)
+--import qualified Database.PostgreSQL.Simple as DPS
+--import Database.PostgreSQL.Simple.SqlQQ (sql)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Data.Swagger
-import Data.Text (Text)
+import qualified Data.Text as T
import Data.Time (UTCTime)
import Data.Time.Segment (jour)
-import GHC.Generics (Generic)
import Opaleye
-import Prelude hiding (null, id, map, sum, not, read)
+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)
-import Gargantext.Database.Admin.Config (nodeTypeId)
+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.Node (queryNodeSearchTable)
import Gargantext.Database.Query.Table.NodeNode
import Gargantext.Database.Query.Table.NodeNodeNgrams
import Gargantext.Database.Prelude
import Gargantext.Database.Schema.Node
+import Gargantext.Prelude (printDebug)
------------------------------------------------------------------------
-- | DocFacet
--instance FromJSON Facet
--instance ToJSON Facet
-type Favorite = Int
+type Category = Int
+type Score = Double
type Title = Text
-- TODO remove Title
-type FacetDoc = Facet NodeId UTCTime Title HyperdataDocument (Maybe Favorite) (Maybe Double)
+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 favorite ngramCount =
+data Facet id created title hyperdata category ngramCount score =
FacetDoc { facetDoc_id :: id
, facetDoc_created :: created
, facetDoc_title :: title
, facetDoc_hyperdata :: hyperdata
- , facetDoc_favorite :: favorite
+ , facetDoc_category :: category
, facetDoc_ngramCount :: ngramCount
+ , facetDoc_score :: score
} deriving (Show, Generic)
{- | TODO after demo
data Facet id date hyperdata score =
} deriving (Show, Generic)
-}
-data Pair i l = Pair {_p_id :: i
- ,_p_label :: l
+data Pair i l = Pair {
+ _p_id :: i
+ , _p_label :: l
} deriving (Show, Generic)
$(deriveJSON (unPrefix "_p_") ''Pair)
$(makeAdaptorAndInstance "pPair" ''Pair)
-instance (ToSchema i, ToSchema l) => ToSchema (Pair i l) where
- declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_p_")
+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 pair =
- FacetPaired {_fp_id :: id
- ,_fp_date :: date
- ,_fp_hyperdata :: hyperdata
- ,_fp_score :: score
- ,_fp_pair :: pair
- } deriving (Show, Generic)
+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
- , ToSchema pair
- ) => ToSchema (FacetPaired id date hyperdata score pair) where
- declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_fp_")
+ , 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 pair
- ) => Arbitrary (FacetPaired id date hyperdata score pair) where
- arbitrary = FacetPaired <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+ ) => Arbitrary (FacetPaired id date hyperdata score) where
+ arbitrary = FacetPaired <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
type FacetPairedRead = FacetPaired (Column PGInt4 )
(Column PGTimestamptz)
(Column PGJsonb )
(Column PGInt4 )
- ( Column (Nullable PGInt4)
- , Column (Nullable PGText)
- )
+
+type FacetPairedReadNull = FacetPaired (Column (Nullable PGInt4) )
+ (Column (Nullable PGTimestamptz))
+ (Column (Nullable PGJsonb) )
+ (Column (Nullable PGInt4) )
+
+type FacetPairedReadNullAgg = FacetPaired (Aggregator (Column (Nullable PGInt4) )
+ (Column (Nullable PGInt4) )
+ )
+ (Aggregator (Column (Nullable PGTimestamptz))
+ (Column (Nullable PGTimestamptz))
+
+ )
+ (Aggregator (Column (Nullable PGJsonb) )
+ (Column (Nullable PGJsonb) )
+ )
+ (Aggregator (Column (Nullable PGInt4) )
+ (Column (Nullable PGInt4) )
+ )
+
+
+
-- | JSON instance
$(deriveJSON (unPrefix "facetDoc_") ''Facet)
-- | Mock and Quickcheck instances
instance Arbitrary FacetDoc where
- arbitrary = elements [ FacetDoc id' (jour year 01 01) t hp (Just cat) (Just ngramCount)
+ 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
(Column PGText )
(Column PGJsonb )
(Column (Nullable PGInt4)) -- Category
+ (Column (Nullable PGFloat8)) -- Ngrams Count
(Column (Nullable PGFloat8)) -- Score
-----------------------------------------------------------------------
-- TODO-SECURITY check
--{-
-runViewAuthorsDoc :: ContactId -> IsTrash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
+runViewAuthorsDoc :: HasDBid NodeType
+ => ContactId
+ -> IsTrash
+ -> Maybe Offset
+ -> Maybe Limit
+ -> Maybe OrderBy
+ -> Cmd err [FacetDoc]
runViewAuthorsDoc cId t o l order = runOpaQuery $ filterWith o l order $ viewAuthorsDoc cId t ntId
where
ntId = NodeDocument
-- TODO add delete ?
-viewAuthorsDoc :: ContactId -> IsTrash -> NodeType -> Query FacetDocRead
+viewAuthorsDoc :: HasDBid NodeType
+ => ContactId
+ -> IsTrash
+ -> NodeType
+ -> Query FacetDocRead
viewAuthorsDoc cId _ nt = proc () -> do
- (doc,(_,(_,(_,contact)))) <- queryAuthorsDoc -< ()
+ (doc,(_,(_,(_,contact')))) <- queryAuthorsDoc -< ()
{-nn <- queryNodeNodeTable -< ()
restrict -< nn_node1_id nn .== _node_id doc
-- restrict -< nn_delete nn .== (pgBool t)
-}
- restrict -< _node_id contact .== (toNullable $ pgNodeId cId)
- restrict -< _node_typename doc .== (pgInt4 $ nodeTypeId nt)
+ restrict -< _node_id contact' .== (toNullable $ pgNodeId cId)
+ restrict -< _node_typename doc .== (sqlInt4 $ toDBid nt)
returnA -< FacetDoc (_node_id doc)
(_node_date doc)
(_node_name doc)
(_node_hyperdata doc)
- (toNullable $ pgInt4 1)
+ (toNullable $ sqlInt4 1)
+ (toNullable $ pgDouble 1)
(toNullable $ pgDouble 1)
queryAuthorsDoc :: Query (NodeRead, (NodeNodeNgramsReadNull, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull))))
.== _nnng_node1_id nodeNgram
cond23 :: (NgramsRead, (NodeNodeNgramsRead, NodeReadNull)) -> Column PGBool
- cond23 (ngrams, (nodeNgram, _)) = ngrams^.ngrams_id
+ cond23 (ngrams', (nodeNgram, _)) = ngrams'^.ngrams_id
.== _nnng_ngrams_id nodeNgram
cond34 :: (NodeNodeNgramsRead, (NgramsRead, (NodeNodeNgramsReadNull, NodeReadNull))) -> Column PGBool
- cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams^.ngrams_id .== _nnng_ngrams_id nodeNgram2
+ cond34 (nodeNgram2, (ngrams', (_,_)))= ngrams'^.ngrams_id .== _nnng_ngrams_id nodeNgram2
cond45 :: (NodeRead, (NodeNodeNgramsRead, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull)))) -> Column PGBool
- cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id contact .== _nnng_node1_id nodeNgram2
+ cond45 (contact', (nodeNgram2', (_, (_,_)))) = _node_id contact' .== _nnng_node1_id nodeNgram2'
--}
------------------------------------------------------------------------
-- TODO-SECURITY check
-runViewDocuments :: CorpusId -> IsTrash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
-runViewDocuments cId t o l order =
- runOpaQuery $ filterWith o l order $ viewDocuments cId t ntId
+runViewDocuments :: HasDBid NodeType
+ => CorpusId
+ -> IsTrash
+ -> Maybe Offset
+ -> Maybe Limit
+ -> Maybe OrderBy
+ -> Maybe Text
+ -> Cmd err [FacetDoc]
+runViewDocuments cId t o l order query = do
+-- docs <- runPGSQuery viewDocuments'
+-- ( cId
+-- , ntId
+-- , (if t then 0 else 1) :: Int
+-- , fromMaybe "" query
+-- , fromMaybe "" query)
+-- pure $ (\(id, date, name', hyperdata, category, score) -> FacetDoc id date name' hyperdata category score score) <$> docs
+ printDebug "[runViewDocuments] sqlQuery" $ showSql sqlQuery
+ runOpaQuery $ filterWith o l order sqlQuery
where
- ntId = nodeTypeId NodeDocument
+ ntId = toDBid NodeDocument
+ sqlQuery = viewDocuments cId t ntId query
+-- viewDocuments' :: DPS.Query
+-- viewDocuments' = [sql|
+-- SELECT n.id, n.date, n.name, n.hyperdata, nn.category, nn.score
+-- FROM nodes AS n
+-- JOIN nodes_nodes AS nn
+-- ON n.id = nn.node2_id
+-- WHERE nn.node1_id = ? -- corpusId
+-- AND n.typename = ? -- NodeTypeId
+-- AND nn.category = ? -- isTrash or not
+-- AND (n.search @@ to_tsquery(?) OR ? = '') -- query with an OR hack for empty to_tsquery('') results
+-- |]
+
+runCountDocuments :: HasDBid NodeType => CorpusId -> IsTrash -> Maybe Text -> Cmd err Int
+runCountDocuments cId t mQuery = do
+ runCountOpaQuery sqlQuery
+ where
+ sqlQuery = viewDocuments cId t (toDBid NodeDocument) mQuery
+
-viewDocuments :: CorpusId -> IsTrash -> NodeTypeId -> Query FacetDocRead
-viewDocuments cId t ntId = proc () -> do
- n <- queryNodeTable -< ()
+viewDocuments :: CorpusId
+ -> IsTrash
+ -> NodeTypeId
+ -> Maybe Text
+ -> Query FacetDocRead
+viewDocuments cId t ntId mQuery = proc () -> do
+ --n <- queryNodeTable -< ()
+ n <- queryNodeSearchTable -< ()
nn <- queryNodeNodeTable -< ()
- restrict -< n^.node_id .== nn^.nn_node2_id
+ restrict -< n^.ns_id .== nn^.nn_node2_id
restrict -< nn^.nn_node1_id .== (pgNodeId cId)
- restrict -< n^.node_typename .== (pgInt4 ntId)
- restrict -< if t then nn^.nn_category .== (pgInt4 0)
- else nn^.nn_category .>= (pgInt4 1)
- returnA -< FacetDoc (_node_id n)
- (_node_date n)
- (_node_name n)
- (_node_hyperdata n)
+ restrict -< n^.ns_typename .== (sqlInt4 ntId)
+ restrict -< if t then nn^.nn_category .== (sqlInt4 0)
+ else nn^.nn_category .>= (sqlInt4 1)
+
+ let query = (fromMaybe "" mQuery)
+ -- iLikeQuery = T.intercalate "" ["%", query, "%"]
+ -- restrict -< (n^.node_name) `ilike` (sqlStrictText iLikeQuery)
+ restrict -< if query == ""
+ then pgBool True
+ --else (n^.ns_search) @@ (pgTSQuery (T.unpack query))
+ else (n^.ns_search) @@ (plaintoTSQuery $ T.unpack query)
+
+ returnA -< FacetDoc (_ns_id n)
+ (_ns_date n)
+ (_ns_name n)
+ (_ns_hyperdata n)
(toNullable $ nn^.nn_category)
(toNullable $ nn^.nn_score)
+ (toNullable $ nn^.nn_score)
------------------------------------------------------------------------
-filterWith :: (PGOrd date, PGOrd title, PGOrd score, hyperdata ~ Column SqlJsonb) =>
- Maybe Gargantext.Core.Types.Offset
+filterWith :: (SqlOrd date, SqlOrd title, SqlOrd category, SqlOrd score, hyperdata ~ Column SqlJsonb) =>
+ Maybe Gargantext.Core.Types.Offset
-> Maybe Gargantext.Core.Types.Limit
-> Maybe OrderBy
- -> Select (Facet id (Column date) (Column title) hyperdata (Column score) ngramCount)
- -> Select (Facet id (Column date) (Column title) hyperdata (Column score) ngramCount)
+ -> Select (Facet id (Column date) (Column title) hyperdata (Column category) ngramCount (Column score))
+ -> Select (Facet id (Column date) (Column title) hyperdata (Column category) ngramCount (Column score))
filterWith o l order q = limit' l $ offset' o $ orderBy (orderWith order) q
-orderWith :: (PGOrd b1, PGOrd b2, PGOrd b3)
+orderWith :: (SqlOrd b1, SqlOrd b2, SqlOrd b3, SqlOrd b4)
=> Maybe OrderBy
- -> Order (Facet id (Column b1) (Column b2) (Column SqlJsonb) (Column b3) score)
+ -> Order (Facet id (Column b1) (Column b2) (Column SqlJsonb) (Column b3) ngramCount (Column b4))
orderWith (Just DateAsc) = asc facetDoc_created
orderWith (Just DateDesc) = desc facetDoc_created
orderWith (Just TitleAsc) = asc facetDoc_title
orderWith (Just TitleDesc) = desc facetDoc_title
-orderWith (Just ScoreAsc) = asc facetDoc_favorite
-orderWith (Just ScoreDesc) = desc facetDoc_favorite
+orderWith (Just ScoreAsc) = asc facetDoc_score
+orderWith (Just ScoreDesc) = descNullsLast facetDoc_score
orderWith (Just SourceAsc) = asc facetDoc_source
orderWith (Just SourceDesc) = desc facetDoc_source
orderWith _ = asc facetDoc_created
-facetDoc_source :: PGIsJson a
- => Facet id created title (Column a) favorite ngramCount
+facetDoc_source :: SqlIsJson a
+ => Facet id created title (Column a) favorite ngramCount score
-> Column (Nullable PGText)
facetDoc_source x = toNullable (facetDoc_hyperdata x) .->> pgString "source"