2 Module : Gargantext.Database.Facet
3 Description : Main requests of Node to the database
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
11 {-# OPTIONS_GHC -fno-warn-orphans #-}
12 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
14 {-# LANGUAGE Arrows #-}
15 {-# LANGUAGE DeriveGeneric #-}
16 {-# LANGUAGE FlexibleContexts #-}
17 {-# LANGUAGE FlexibleInstances #-}
18 {-# LANGUAGE FunctionalDependencies #-}
19 {-# LANGUAGE MultiParamTypeClasses #-}
20 {-# LANGUAGE QuasiQuotes #-}
21 {-# LANGUAGE NoImplicitPrelude #-}
22 {-# LANGUAGE NoMonomorphismRestriction #-}
23 {-# LANGUAGE OverloadedStrings #-}
24 {-# LANGUAGE RankNTypes #-}
25 {-# LANGUAGE TemplateHaskell #-}
26 ------------------------------------------------------------------------
27 module Gargantext.Database.Facet
29 ------------------------------------------------------------------------
30 import Control.Arrow (returnA)
31 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
32 import Data.Aeson (FromJSON, ToJSON)
33 import Data.Aeson.TH (deriveJSON)
34 import Data.Either(Either(Left))
35 import Data.Maybe (Maybe)
36 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
38 import Data.Text (Text)
39 import Data.Time (UTCTime)
40 import Data.Time.Segment (jour)
41 import GHC.Generics (Generic)
42 import Gargantext.Core.Types
43 import Gargantext.Core.Utils.Prefix (unPrefix)
44 import Gargantext.Database.Config (nodeTypeId)
45 import Gargantext.Database.Schema.Ngrams
46 import Gargantext.Database.Schema.Node
47 import Gargantext.Database.Schema.NodeNgram
48 import Gargantext.Database.Schema.NodeNode
49 import Gargantext.Database.Utils
50 import Gargantext.Database.Queries.Join
51 import Gargantext.Database.Queries.Filter
53 import Prelude hiding (null, id, map, sum, not, read)
55 import Test.QuickCheck (elements)
56 import Test.QuickCheck.Arbitrary
57 import qualified Opaleye.Internal.Unpackspec()
59 ------------------------------------------------------------------------
62 -- data Facet = FacetDoc | FacetSources | FacetAuthors | FacetTerms
63 -- deriving (Show, Generic)
64 --instance FromJSON Facet
65 --instance ToJSON Facet
70 type FacetDoc = Facet NodeId UTCTime Title HyperdataDocument Favorite Int
71 type FacetSources = FacetDoc
72 type FacetAuthors = FacetDoc
73 type FacetTerms = FacetDoc
76 data Facet id created title hyperdata favorite ngramCount =
77 FacetDoc { facetDoc_id :: id
78 , facetDoc_created :: created
79 , facetDoc_title :: title
80 , facetDoc_hyperdata :: hyperdata
81 , facetDoc_favorite :: favorite
82 , facetDoc_ngramCount :: ngramCount
83 } deriving (Show, Generic)
85 data Facet id date hyperdata score =
86 FacetDoc { facetDoc_id :: id
87 , facetDoc_date :: date
88 , facetDoc_hyperdata :: hyperdata
89 , facetDoc_score :: score
90 } deriving (Show, Generic)
93 data Pair i l = Pair {_p_id :: i
95 } deriving (Show, Generic)
96 $(deriveJSON (unPrefix "_p_") ''Pair)
97 $(makeAdaptorAndInstance "pPair" ''Pair)
99 instance (ToSchema i, ToSchema l) => ToSchema (Pair i l) where
101 genericDeclareNamedSchema
102 defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 3 fieldLabel}
103 instance (Arbitrary i, Arbitrary l) => Arbitrary (Pair i l) where
104 arbitrary = Pair <$> arbitrary <*> arbitrary
106 data FacetPaired id date hyperdata score pairs =
107 FacetPaired {_fp_id :: id
109 ,_fp_hyperdata :: hyperdata
112 } deriving (Show, Generic)
113 $(deriveJSON (unPrefix "_fp_") ''FacetPaired)
114 $(makeAdaptorAndInstance "pFacetPaired" ''FacetPaired)
116 instance (ToSchema id, ToSchema date, ToSchema hyperdata, ToSchema pairs, ToSchema score) => ToSchema (FacetPaired id date hyperdata score pairs) where
118 genericDeclareNamedSchema
119 defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
121 instance ( Arbitrary id
123 , Arbitrary hyperdata
126 ) => Arbitrary (FacetPaired id date hyperdata score pairs) where
127 arbitrary = FacetPaired <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
130 type FacetPairedRead = FacetPaired (Column PGInt4 )
131 (Column PGTimestamptz)
134 (Pair (Column (Nullable PGInt4)) (Column (Nullable PGText)))
140 $(deriveJSON (unPrefix "facetDoc_") ''Facet)
142 -- | Documentation instance
143 instance ToSchema FacetDoc
145 -- | Mock and Quickcheck instances
146 instance Arbitrary FacetDoc where
147 arbitrary = elements [ FacetDoc id' (jour year 01 01) t hp fav ngramCount
149 , year <- [1990..2000]
150 , t <- ["title", "another title"]
151 , hp <- hyperdataDocuments
152 , fav <- [True, False]
153 , ngramCount <- [3..100]
156 -- Facets / Views for the Front End
157 -- | Database instances
158 $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
159 $(makeLensesWith abbreviatedFields ''Facet)
161 type FacetDocRead = Facet (Column PGInt4 )
162 (Column PGTimestamptz)
168 -----------------------------------------------------------------------
170 data FacetChart = FacetChart { facetChart_time :: UTCTime'
171 , facetChart_count :: Double
173 deriving (Show, Generic)
174 $(deriveJSON (unPrefix "facetChart_") ''FacetChart)
175 instance ToSchema FacetChart
177 instance Arbitrary FacetChart where
178 arbitrary = FacetChart <$> arbitrary <*> arbitrary
180 -----------------------------------------------------------------------
182 data OrderBy = DateAsc | DateDesc
183 | TitleAsc | TitleDesc
184 | ScoreDesc | ScoreAsc
185 deriving (Generic, Enum, Bounded, Read, Show)
188 instance FromHttpApiData OrderBy
190 parseUrlPiece "DateAsc" = pure DateAsc
191 parseUrlPiece "DateDesc" = pure DateDesc
192 parseUrlPiece "TitleAsc" = pure TitleAsc
193 parseUrlPiece "TitleDesc" = pure TitleDesc
194 parseUrlPiece "ScoreAsc" = pure ScoreAsc
195 parseUrlPiece "ScoreDesc" = pure ScoreDesc
196 parseUrlPiece _ = Left "Unexpected value of OrderBy"
198 instance ToParamSchema OrderBy
199 instance FromJSON OrderBy
200 instance ToJSON OrderBy
201 instance ToSchema OrderBy
202 instance Arbitrary OrderBy
204 arbitrary = elements [minBound..maxBound]
207 runViewAuthorsDoc :: ContactId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
208 runViewAuthorsDoc cId t o l order = runOpaQuery $ filterWith o l order $ viewAuthorsDoc cId t ntId
213 viewAuthorsDoc :: ContactId -> Trash -> NodeType -> Query FacetDocRead
214 viewAuthorsDoc cId _ nt = proc () -> do
215 (doc,(_,(_,(_,contact)))) <- queryAuthorsDoc -< ()
217 {-nn <- queryNodeNodeTable -< ()
218 restrict -< nodeNode_node1_id nn .== _node_id doc
219 -- restrict -< nodeNode_delete nn .== (pgBool t)
222 restrict -< _node_id contact .== (toNullable $ pgNodeId cId)
223 restrict -< _node_typename doc .== (pgInt4 $ nodeTypeId nt)
225 returnA -< FacetDoc (_node_id doc) (_node_date doc) (_node_name doc) (_node_hyperdata doc) (pgBool True) (pgInt4 1)
227 queryAuthorsDoc :: Query (NodeRead, (NodeNgramReadNull, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull))))
228 queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable queryNodeNgramTable queryNodeTable cond12 cond23 cond34 cond45
230 cond12 :: (NodeNgramRead, NodeRead) -> Column PGBool
231 cond12 (nodeNgram, doc) = _node_id doc
232 .== _nn_node_id nodeNgram
234 cond23 :: (NgramsRead, (NodeNgramRead, NodeReadNull)) -> Column PGBool
235 cond23 (ngrams, (nodeNgram, _)) = ngrams_id ngrams
236 .== _nn_ngrams_id nodeNgram
238 cond34 :: (NodeNgramRead, (NgramsRead, (NodeNgramReadNull, NodeReadNull))) -> Column PGBool
239 cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams_id ngrams .== _nn_ngrams_id nodeNgram2
241 cond45 :: (NodeRead, (NodeNgramRead, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull)))) -> Column PGBool
242 cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id contact .== _nn_node_id nodeNgram2
245 ------------------------------------------------------------------------
247 runViewDocuments :: CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
248 runViewDocuments cId t o l order =
249 runOpaQuery $ filterWith o l order $ viewDocuments cId t ntId
251 ntId = nodeTypeId NodeDocument
253 viewDocuments :: CorpusId -> Trash -> NodeTypeId -> Query FacetDocRead
254 viewDocuments cId t ntId = proc () -> do
255 n <- queryNodeTable -< ()
256 nn <- queryNodeNodeTable -< ()
257 restrict -< _node_id n .== nodeNode_node2_id nn
258 restrict -< nodeNode_node1_id nn .== (pgNodeId cId)
259 restrict -< _node_typename n .== (pgInt4 ntId)
260 restrict -< nodeNode_delete nn .== (pgBool t)
261 returnA -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (nodeNode_favorite nn) (pgInt4 1)
264 ------------------------------------------------------------------------
265 filterWith :: (PGOrd date, PGOrd title, PGOrd score) =>
266 Maybe Gargantext.Core.Types.Offset
267 -> Maybe Gargantext.Core.Types.Limit
269 -> Select (Facet id (Column date) (Column title) hyperdata (Column score) ngramCount)
270 -> Select (Facet id (Column date) (Column title) hyperdata (Column score) ngramCount)
271 filterWith o l order q = limit' l $ offset' o $ orderBy (orderWith order) q
274 orderWith :: (PGOrd b1, PGOrd b2, PGOrd b3) => Maybe OrderBy -> Order (Facet id (Column b1) (Column b2) hyperdata (Column b3) score)
275 orderWith order = case order of
276 (Just DateAsc) -> asc facetDoc_created
278 (Just TitleAsc) -> asc facetDoc_title
279 (Just TitleDesc) -> desc facetDoc_title
281 (Just ScoreAsc) -> asc facetDoc_favorite
282 (Just ScoreDesc) -> desc facetDoc_favorite
283 _ -> desc facetDoc_created