{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
------------------------------------------------------------------------
module Gargantext.Database.Facet
where
------------------------------------------------------------------------
-
import Control.Arrow (returnA)
import Control.Lens.TH (makeLensesWith, abbreviatedFields)
import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson.TH (deriveJSON)
import Data.Either(Either(Left))
import Data.Maybe (Maybe)
-import Data.Profunctor.Product.Default
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Data.Swagger
import Data.Text (Text)
import Data.Time (UTCTime)
import Data.Time.Segment (jour)
-import Database.PostgreSQL.Simple (Connection)
import GHC.Generics (Generic)
import Gargantext.Core.Types
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Config (nodeTypeId)
-import Gargantext.Database.Ngrams
-import Gargantext.Database.Node
-import Gargantext.Database.NodeNgram
-import Gargantext.Database.NodeNode
-import Gargantext.Database.Queries
+import Gargantext.Database.Schema.Ngrams
+import Gargantext.Database.Schema.Node
+import Gargantext.Database.Schema.NodeNgram
+import Gargantext.Database.Schema.NodeNode
+import Gargantext.Database.Utils
+import Gargantext.Database.Queries.Join
+import Gargantext.Database.Queries.Filter
import Opaleye
-import Opaleye.Internal.Join (NullMaker(..))
-import Prelude (Enum, Bounded, minBound, maxBound)
import Prelude hiding (null, id, map, sum, not, read)
import Servant.API
import Test.QuickCheck (elements)
type FacetTerms = FacetDoc
-
data Facet id created title hyperdata favorite ngramCount =
FacetDoc { facetDoc_id :: id
, facetDoc_created :: created
, facetDoc_favorite :: favorite
, facetDoc_ngramCount :: ngramCount
} 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 (ToSchema i, ToSchema l) => ToSchema (Pair i l) where
+ declareNamedSchema =
+ genericDeclareNamedSchema
+ defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 3 fieldLabel}
+instance (Arbitrary i, Arbitrary l) => Arbitrary (Pair i l) where
+ arbitrary = Pair <$> arbitrary <*> arbitrary
+
+data FacetPaired id date hyperdata score pairs =
+ FacetPaired {_fp_id :: id
+ ,_fp_date :: date
+ ,_fp_hyperdata :: hyperdata
+ ,_fp_score :: score
+ ,_fp_pairs :: pairs
+ } deriving (Show, Generic)
+$(deriveJSON (unPrefix "_fp_") ''FacetPaired)
+$(makeAdaptorAndInstance "pFacetPaired" ''FacetPaired)
+
+instance (ToSchema id, ToSchema date, ToSchema hyperdata, ToSchema pairs, ToSchema score) => ToSchema (FacetPaired id date hyperdata score pairs) where
+ declareNamedSchema =
+ genericDeclareNamedSchema
+ defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
+
+instance ( Arbitrary id
+ , Arbitrary date
+ , Arbitrary hyperdata
+ , Arbitrary score
+ , Arbitrary pairs
+ ) => Arbitrary (FacetPaired id date hyperdata score pairs) where
+ arbitrary = FacetPaired <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+
+--{-
+type FacetPairedRead = FacetPaired (Column PGInt4 )
+ (Column PGTimestamptz)
+ (Column PGJsonb )
+ (Column PGInt4 )
+ (Pair (Column (Nullable PGInt4)) (Column (Nullable PGText)))
+--}
--- | JSON instance
+
+-- | JSON instance
$(deriveJSON (unPrefix "facetDoc_") ''Facet)
-- | Documentation instance
instance ToSchema FacetDoc
-- | Mock and Quickcheck instances
-
instance Arbitrary FacetDoc where
arbitrary = elements [ FacetDoc id' (jour year 01 01) t hp fav ngramCount
| id' <- [1..10]
, year <- [1990..2000]
, t <- ["title", "another title"]
- , hp <- hyperdataDocuments
+ , hp <- arbitraryHyperdataDocuments
, fav <- [True, False]
, ngramCount <- [3..100]
]
(Column PGInt4 )
-----------------------------------------------------------------------
-
-data FacetChart = FacetChart { facetChart_time :: UTCTime'
- , facetChart_count :: Double
- }
- deriving (Show, Generic)
-$(deriveJSON (unPrefix "facetChart_") ''FacetChart)
-instance ToSchema FacetChart
-
-instance Arbitrary FacetChart where
- arbitrary = FacetChart <$> arbitrary <*> arbitrary
-
-----------------------------------------------------------------------
type Trash = Bool
-data OrderBy = DateAsc | DateDesc
- | TitleAsc | TitleDesc
- | FavDesc | FavAsc
+data OrderBy = DateAsc | DateDesc
+ | TitleAsc | TitleDesc
+ | ScoreDesc | ScoreAsc
+ | SourceAsc | SourceDesc
deriving (Generic, Enum, Bounded, Read, Show)
- -- | NgramCoun
instance FromHttpApiData OrderBy
where
- parseUrlPiece "DateAsc" = pure DateAsc
- parseUrlPiece "DateDesc" = pure DateDesc
- parseUrlPiece "TitleAsc" = pure TitleAsc
- parseUrlPiece "TitleDesc" = pure TitleDesc
- parseUrlPiece "FavAsc" = pure FavAsc
- parseUrlPiece "FavDesc" = pure FavDesc
- parseUrlPiece _ = Left "Unexpected value of OrderBy"
+ 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 _ = Left "Unexpected value of OrderBy"
instance ToParamSchema OrderBy
instance FromJSON OrderBy
arbitrary = elements [minBound..maxBound]
-runViewAuthorsDoc :: Connection -> ContactId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [FacetDoc]
-runViewAuthorsDoc c cId t o l order = runQuery c (filterDocuments o l order $ viewAuthorsDoc cId t ntId)
+runViewAuthorsDoc :: ContactId -> Trash -> 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
(doc,(_,(_,(_,contact)))) <- queryAuthorsDoc -< ()
{-nn <- queryNodeNodeTable -< ()
- restrict -< nodeNode_node1_id nn .== _node_id doc
- -- restrict -< nodeNode_delete nn .== (pgBool t)
+ restrict -< nn_node1_id nn .== _node_id doc
+ -- restrict -< nn_delete nn .== (pgBool t)
-}
- restrict -< _node_id contact .== (toNullable $ pgInt4 cId)
+ restrict -< _node_id contact .== (toNullable $ pgNodeId cId)
restrict -< _node_typename doc .== (pgInt4 $ nodeTypeId nt)
returnA -< FacetDoc (_node_id doc) (_node_date doc) (_node_name doc) (_node_hyperdata doc) (pgBool True) (pgInt4 1)
where
cond12 :: (NodeNgramRead, NodeRead) -> Column PGBool
cond12 (nodeNgram, doc) = _node_id doc
- .== nodeNgram_NodeNgramNodeId nodeNgram
+ .== nng_node_id nodeNgram
cond23 :: (NgramsRead, (NodeNgramRead, NodeReadNull)) -> Column PGBool
cond23 (ngrams, (nodeNgram, _)) = ngrams_id ngrams
- .== nodeNgram_NodeNgramNgramId nodeNgram
+ .== nng_ngrams_id nodeNgram
cond34 :: (NodeNgramRead, (NgramsRead, (NodeNgramReadNull, NodeReadNull))) -> Column PGBool
- cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams_id ngrams .== nodeNgram_NodeNgramNgramId nodeNgram2
+ cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams_id ngrams .== nng_ngrams_id nodeNgram2
cond45 :: (NodeRead, (NodeNgramRead, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull)))) -> Column PGBool
- cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id contact .== nodeNgram_NodeNgramNodeId nodeNgram2
+ cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id contact .== nng_node_id nodeNgram2
------------------------------------------------------------------------
-runViewDocuments :: CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd [FacetDoc]
-runViewDocuments cId t o l order = mkCmd $ \c -> runViewDocuments' c cId t o l order
-
--- | TODO use only Cmd with Reader and delete function below
-runViewDocuments' :: Connection -> CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [FacetDoc]
-runViewDocuments' c cId t o l order = runQuery c ( filterDocuments o l order
- $ viewDocuments cId t ntId)
+runViewDocuments :: CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
+runViewDocuments cId t o l order =
+ runOpaQuery $ filterWith o l order $ viewDocuments cId t ntId
where
ntId = nodeTypeId NodeDocument
viewDocuments cId t ntId = proc () -> do
n <- queryNodeTable -< ()
nn <- queryNodeNodeTable -< ()
- restrict -< _node_id n .== nodeNode_node2_id nn
- restrict -< nodeNode_node1_id nn .== (pgInt4 cId)
- restrict -< _node_typename n .== (pgInt4 ntId)
- restrict -< nodeNode_delete nn .== (pgBool t)
- returnA -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (nodeNode_favorite nn) (pgInt4 1)
+ restrict -< _node_id n .== nn_node2_id nn
+ restrict -< nn_node1_id nn .== (pgNodeId cId)
+ restrict -< _node_typename n .== (pgInt4 ntId)
+ restrict -< nn_delete nn .== (pgBool t)
+ returnA -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (nn_favorite nn) (pgInt4 1)
------------------------------------------------------------------------
-
-filterDocuments :: (PGOrd date, PGOrd title, PGOrd favorite) =>
+filterWith :: (PGOrd date, PGOrd title, PGOrd 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 favorite) ngramCount)
- -> Query (Facet id (Column date) (Column title) hyperdata (Column favorite) ngramCount)
-filterDocuments o l order q = limit' l $ offset' o $ orderBy ordering q
- where
- ordering = case order of
- (Just DateAsc) -> asc facetDoc_created
-
- (Just TitleAsc) -> asc facetDoc_title
- (Just TitleDesc) -> desc facetDoc_title
-
- (Just FavAsc) -> asc facetDoc_favorite
- (Just FavDesc) -> desc facetDoc_favorite
- _ -> desc facetDoc_created
-
-
-
+ -> Select (Facet id (Column date) (Column title) hyperdata (Column score) ngramCount)
+ -> Select (Facet id (Column date) (Column title) hyperdata (Column score) ngramCount)
+filterWith o l order q = limit' l $ offset' o $ orderBy (orderWith order) q
-------------------------------------------------------------------------
--- | TODO move this queries utilties elsewhere
-leftJoin3' :: Query (NodeRead, (NodeNodeReadNull, NodeReadNull))
-leftJoin3' = leftJoin3 queryNodeNodeTable queryNodeTable queryNodeTable cond12 cond23
- where
- cond12 = undefined
- cond23 :: (NodeRead, (NodeNodeRead, NodeReadNull)) -> Column PGBool
- cond23 = undefined
-
-
-leftJoin3 :: ( Default Unpackspec columnsL1 columnsL1
- , Default Unpackspec columnsL2 columnsL2
- , Default Unpackspec columnsL3 columnsL3
-
- , Default Unpackspec nullableColumnsL2 nullableColumnsL2
-
- , Default NullMaker columnsL2 nullableColumnsL2
- , Default NullMaker (columnsL1, nullableColumnsL2) nullableColumnsL3
- )
- =>
- Query columnsL1 -> Query columnsL2 -> Query columnsL3
- -> ((columnsL1, columnsL2) -> Column PGBool)
- -> ((columnsL3, (columnsL1, nullableColumnsL2)) -> Column PGBool)
- -> Query (columnsL3, nullableColumnsL3)
-leftJoin3 q1 q2 q3 cond12 cond23 = leftJoin q3 (leftJoin q1 q2 cond12) cond23
+orderWith :: (PGOrd b1, PGOrd b2, PGOrd b3)
+ => Maybe OrderBy
+ -> Order (Facet id (Column b1) (Column b2) (Column SqlJsonb) (Column b3) score)
+orderWith (Just DateAsc) = asc facetDoc_created
+orderWith (Just DateDesc) = desc facetDoc_created
---{-
+orderWith (Just TitleAsc) = asc facetDoc_title
+orderWith (Just TitleDesc) = desc facetDoc_title
-leftJoin4' :: Query (NodeRead, (NodeReadNull, (NodeReadNull, NodeReadNull)))
-leftJoin4' = leftJoin4 queryNodeTable queryNodeTable queryNodeTable queryNodeTable cond12 cond23 cond34
- where
- cond12 = undefined
-
- cond23 :: (NodeRead, (NodeRead, NodeReadNull)) -> Column PGBool
- cond23 = undefined
-
- cond34 :: (NodeRead, (NodeRead, (NodeReadNull, NodeReadNull))) -> Column PGBool
- cond34 = undefined
-
-
-leftJoin4 :: ( Default Unpackspec fieldsL1 fieldsL1,
- Default Unpackspec fieldsL2 fieldsL2,
- Default Unpackspec fieldsL3 fieldsL3,
- Default Unpackspec fieldsR fieldsR,
-
- Default Unpackspec nullableFieldsL1 nullableFieldsL1,
- Default Unpackspec nullableFieldsL2 nullableFieldsL2,
- Default NullMaker fieldsR nullableFieldsL2,
- Default NullMaker (fieldsL2, nullableFieldsL1) nullableFieldsL3,
- Default NullMaker (fieldsL3, nullableFieldsL2) nullableFieldsL1) =>
- Query fieldsL3
- -> Query fieldsR
- -> Query fieldsL2
- -> Query fieldsL1
- -> ((fieldsL3, fieldsR)
- -> Column PGBool)
- -> ((fieldsL2, (fieldsL3, nullableFieldsL2))
- -> Column PGBool)
- -> ((fieldsL1, (fieldsL2, nullableFieldsL1))
- -> Column PGBool)
- -> Query (fieldsL1, nullableFieldsL3)
-leftJoin4 q1 q2 q3 q4 cond12 cond23 cond34 = leftJoin q4 (leftJoin q3 (leftJoin q1 q2 cond12) cond23) cond34
---}
+orderWith (Just ScoreAsc) = asc facetDoc_favorite
+orderWith (Just ScoreDesc) = desc facetDoc_favorite
-{-
--}
-leftJoin5' :: Query (NodeRead, (NodeReadNull, (NodeReadNull, (NodeReadNull, NodeReadNull))))
-leftJoin5' = leftJoin5 queryNodeTable queryNodeTable queryNodeTable queryNodeTable queryNodeTable cond12 cond23 cond34 cond45
- where
- cond12 :: (NodeRead, NodeRead) -> Column PGBool
- cond12 = undefined
-
- cond23 :: (NodeRead, (NodeRead, NodeReadNull)) -> Column PGBool
- cond23 = undefined
-
- cond34 :: (NodeRead, (NodeRead, (NodeReadNull, NodeReadNull))) -> Column PGBool
- cond34 = undefined
-
- cond45 :: (NodeRead, (NodeRead, (NodeReadNull, (NodeReadNull, NodeReadNull)))) -> Column PGBool
- cond45 = undefined
-
-
-leftJoin5 :: ( Default Unpackspec fieldsL1 fieldsL1,
- Default Unpackspec fieldsL2 fieldsL2,
- Default Unpackspec nullableFieldsR1 nullableFieldsR1,
- Default Unpackspec fieldsL3 fieldsL3,
- Default Unpackspec nullableFieldsR2 nullableFieldsR2,
- Default Unpackspec fieldsL4 fieldsL4,
- Default Unpackspec nullableFieldsR3 nullableFieldsR3,
- Default Unpackspec fieldsR fieldsR,
- Default NullMaker fieldsR nullableFieldsR3,
- Default NullMaker (fieldsL2, nullableFieldsR1) nullableFieldsR4,
- Default NullMaker (fieldsL3, nullableFieldsR2) nullableFieldsR1,
- Default NullMaker (fieldsL4, nullableFieldsR3) nullableFieldsR2) =>
- Query fieldsR
- -> Query fieldsL4
- -> Query fieldsL3
- -> Query fieldsL2
- -> Query fieldsL1
- -> ((fieldsL4, fieldsR) -> Column PGBool)
- -> ((fieldsL3, (fieldsL4, nullableFieldsR3)) -> Column PGBool)
- -> ((fieldsL2, (fieldsL3, nullableFieldsR2)) -> Column PGBool)
- -> ((fieldsL1, (fieldsL2, nullableFieldsR1)) -> Column PGBool)
- -> Query (fieldsL1, nullableFieldsR4)
-leftJoin5 q1 q2 q3 q4 q5 cond12 cond23 cond34 cond45 = leftJoin q5 (leftJoin q4 (leftJoin q3 (leftJoin q2 q1 cond12) cond23) cond34) cond45
-
-
-leftJoin6 :: ( Default Unpackspec fieldsL1 fieldsL1,
- Default Unpackspec fieldsL2 fieldsL2,
- Default Unpackspec nullableFieldsR1 nullableFieldsR1,
- Default Unpackspec fieldsL3 fieldsL3,
- Default Unpackspec nullableFieldsR2 nullableFieldsR2,
- Default Unpackspec fieldsL4 fieldsL4,
- Default Unpackspec nullableFieldsR3 nullableFieldsR3,
- Default Unpackspec fieldsL5 fieldsL5,
- Default Unpackspec nullableFieldsR4 nullableFieldsR4,
- Default Unpackspec fieldsR fieldsR,
- Default NullMaker fieldsR nullableFieldsR4,
- Default NullMaker (fieldsL2, nullableFieldsR1) nullableFieldsR5,
- Default NullMaker (fieldsL3, nullableFieldsR2) nullableFieldsR1,
- Default NullMaker (fieldsL4, nullableFieldsR3) nullableFieldsR2,
- Default NullMaker (fieldsL5, nullableFieldsR4) nullableFieldsR3) =>
- Query fieldsR
- -> Query fieldsL5
- -> Query fieldsL4
- -> Query fieldsL3
- -> Query fieldsL2
- -> Query fieldsL1 -> ((fieldsL5, fieldsR) -> Column PGBool)
- -> ((fieldsL4, (fieldsL5, nullableFieldsR4)) -> Column PGBool)
- -> ((fieldsL3, (fieldsL4, nullableFieldsR3)) -> Column PGBool)
- -> ((fieldsL2, (fieldsL3, nullableFieldsR2)) -> Column PGBool)
- -> ((fieldsL1, (fieldsL2, nullableFieldsR1)) -> Column PGBool)
- -> Query (fieldsL1, nullableFieldsR5)
-leftJoin6 q1 q2 q3 q4 q5 q6 cond12 cond23 cond34 cond45 cond56 =
- leftJoin q6 (leftJoin q5 (leftJoin q4 (leftJoin q3 (leftJoin q2 q1 cond12) cond23) cond34) cond45) cond56
+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
+ -> Column (Nullable PGText)
+facetDoc_source x = toNullable (facetDoc_hyperdata x) .->> pgString "source"