]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Database/Query/Facet.hs
Merge branch 'dev' into dev-ngrams-groups
[gargantext.git] / src / Gargantext / Database / Query / Facet.hs
1 {-|
2 Module : Gargantext.Database.Query.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
8 Portability : POSIX
9 -}
10
11 {-# OPTIONS_GHC -fno-warn-orphans #-}
12
13
14 {-# LANGUAGE Arrows #-}
15 {-# LANGUAGE FunctionalDependencies #-}
16 {-# LANGUAGE QuasiQuotes #-}
17 {-# LANGUAGE NoMonomorphismRestriction #-}
18 {-# LANGUAGE TemplateHaskell #-}
19 {-# LANGUAGE TypeFamilies #-}
20 ------------------------------------------------------------------------
21 module Gargantext.Database.Query.Facet
22 ( runViewAuthorsDoc
23 , runViewDocuments
24 , runCountDocuments
25 , filterWith
26
27 , Pair(..)
28 , Facet(..)
29 , FacetDoc
30 , FacetDocRead
31 , FacetPaired(..)
32 , FacetPairedRead
33 , FacetPairedReadNull
34 , FacetPairedReadNullAgg
35 , OrderBy(..)
36 )
37 where
38
39 import Control.Arrow (returnA)
40 import Control.Lens ((^.))
41 import Data.Aeson (FromJSON, ToJSON)
42 import Data.Aeson.TH (deriveJSON)
43 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
44 import Data.Swagger
45 import qualified Data.Text as T
46 import Data.Time (UTCTime)
47 import Data.Time.Segment (jour)
48 import Opaleye
49 import Protolude hiding (null, map, sum, not)
50 import Servant.API
51 import Test.QuickCheck (elements)
52 import Test.QuickCheck.Arbitrary
53 import qualified Opaleye.Internal.Unpackspec()
54
55 import Gargantext.Core
56 import Gargantext.Core.Types
57 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
58 import Gargantext.Database.Admin.Types.Hyperdata
59 import Gargantext.Database.Query.Filter
60 import Gargantext.Database.Query.Join (leftJoin5)
61 import Gargantext.Database.Query.Table.Ngrams
62 import Gargantext.Database.Query.Table.NodeNode
63 import Gargantext.Database.Query.Table.NodeNodeNgrams
64 import Gargantext.Database.Prelude
65 import Gargantext.Database.Schema.Node
66
67 ------------------------------------------------------------------------
68 -- | DocFacet
69
70 -- data Facet = FacetDoc | FacetSources | FacetAuthors | FacetTerms
71 -- deriving (Show, Generic)
72 --instance FromJSON Facet
73 --instance ToJSON Facet
74
75 type Category = Int
76 type Title = Text
77
78 -- TODO remove Title
79 type FacetDoc = Facet NodeId UTCTime Title HyperdataDocument (Maybe Category) (Maybe Double) (Maybe Double)
80 -- type FacetSources = FacetDoc
81 -- type FacetAuthors = FacetDoc
82 -- type FacetTerms = FacetDoc
83
84
85 data Facet id created title hyperdata category ngramCount score =
86 FacetDoc { facetDoc_id :: id
87 , facetDoc_created :: created
88 , facetDoc_title :: title
89 , facetDoc_hyperdata :: hyperdata
90 , facetDoc_category :: category
91 , facetDoc_ngramCount :: ngramCount
92 , facetDoc_score :: score
93 } deriving (Show, Generic)
94 {- | TODO after demo
95 data Facet id date hyperdata score =
96 FacetDoc { facetDoc_id :: id
97 , facetDoc_date :: date
98 , facetDoc_hyperdata :: hyperdata
99 , facetDoc_score :: score
100 } deriving (Show, Generic)
101 -}
102
103 data Pair i l = Pair {
104 _p_id :: i
105 , _p_label :: l
106 } deriving (Show, Generic)
107 $(deriveJSON (unPrefix "_p_") ''Pair)
108 $(makeAdaptorAndInstance "pPair" ''Pair)
109
110 instance (Typeable i, Typeable l, ToSchema i, ToSchema l) => ToSchema (Pair i l) where
111 declareNamedSchema = wellNamedSchema "_p_"
112 instance (Arbitrary i, Arbitrary l) => Arbitrary (Pair i l) where
113 arbitrary = Pair <$> arbitrary <*> arbitrary
114
115 data FacetPaired id date hyperdata score =
116 FacetPaired {_fp_id :: id
117 ,_fp_date :: date
118 ,_fp_hyperdata :: hyperdata
119 ,_fp_score :: score
120 } deriving (Show, Generic)
121 $(deriveJSON (unPrefix "_fp_") ''FacetPaired)
122 $(makeAdaptorAndInstance "pFacetPaired" ''FacetPaired)
123
124
125
126 instance ( ToSchema id
127 , ToSchema date
128 , ToSchema hyperdata
129 , ToSchema score
130 , Typeable id
131 , Typeable date
132 , Typeable hyperdata
133 , Typeable score
134 ) => ToSchema (FacetPaired id date hyperdata score) where
135 declareNamedSchema = wellNamedSchema "_fp_"
136
137 instance ( Arbitrary id
138 , Arbitrary date
139 , Arbitrary hyperdata
140 , Arbitrary score
141 ) => Arbitrary (FacetPaired id date hyperdata score) where
142 arbitrary = FacetPaired <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
143
144 type FacetPairedRead = FacetPaired (Column PGInt4 )
145 (Column PGTimestamptz)
146 (Column PGJsonb )
147 (Column PGInt4 )
148
149 type FacetPairedReadNull = FacetPaired (Column (Nullable PGInt4) )
150 (Column (Nullable PGTimestamptz))
151 (Column (Nullable PGJsonb) )
152 (Column (Nullable PGInt4) )
153
154 type FacetPairedReadNullAgg = FacetPaired (Aggregator (Column (Nullable PGInt4) )
155 (Column (Nullable PGInt4) )
156 )
157 (Aggregator (Column (Nullable PGTimestamptz))
158 (Column (Nullable PGTimestamptz))
159
160 )
161 (Aggregator (Column (Nullable PGJsonb) )
162 (Column (Nullable PGJsonb) )
163 )
164 (Aggregator (Column (Nullable PGInt4) )
165 (Column (Nullable PGInt4) )
166 )
167
168
169
170
171 -- | JSON instance
172 $(deriveJSON (unPrefix "facetDoc_") ''Facet)
173
174 -- | Documentation instance
175 instance ToSchema FacetDoc where
176 declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "facetDoc_")
177
178 -- | Mock and Quickcheck instances
179 instance Arbitrary FacetDoc where
180 arbitrary = elements [ FacetDoc id' (jour year 01 01) t hp (Just cat) (Just ngramCount) (Just score)
181 | id' <- [1..10]
182 , year <- [1990..2000]
183 , t <- ["title", "another title"]
184 , hp <- arbitraryHyperdataDocuments
185 , cat <- [0..2]
186 , ngramCount <- [3..100]
187 , score <- [3..100]
188 ]
189
190 -- Facets / Views for the Front End
191 -- | Database instances
192 $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
193 -- $(makeLensesWith abbreviatedFields ''Facet)
194
195 type FacetDocRead = Facet (Column PGInt4 )
196 (Column PGTimestamptz)
197 (Column PGText )
198 (Column PGJsonb )
199 (Column (Nullable PGInt4)) -- Category
200 (Column (Nullable PGFloat8)) -- Ngrams Count
201 (Column (Nullable PGFloat8)) -- Score
202
203 -----------------------------------------------------------------------
204 -----------------------------------------------------------------------
205 data OrderBy = DateAsc | DateDesc
206 | TitleAsc | TitleDesc
207 | ScoreDesc | ScoreAsc
208 | SourceAsc | SourceDesc
209 deriving (Generic, Enum, Bounded, Read, Show)
210
211 instance FromHttpApiData OrderBy
212 where
213 parseUrlPiece "DateAsc" = pure DateAsc
214 parseUrlPiece "DateDesc" = pure DateDesc
215 parseUrlPiece "TitleAsc" = pure TitleAsc
216 parseUrlPiece "TitleDesc" = pure TitleDesc
217 parseUrlPiece "ScoreAsc" = pure ScoreAsc
218 parseUrlPiece "ScoreDesc" = pure ScoreDesc
219 parseUrlPiece "SourceAsc" = pure SourceAsc
220 parseUrlPiece "SourceDesc" = pure SourceDesc
221 parseUrlPiece _ = Left "Unexpected value of OrderBy"
222
223 instance ToParamSchema OrderBy
224 instance FromJSON OrderBy
225 instance ToJSON OrderBy
226 instance ToSchema OrderBy
227 instance Arbitrary OrderBy
228 where
229 arbitrary = elements [minBound..maxBound]
230
231
232 -- TODO-SECURITY check
233
234 --{-
235 runViewAuthorsDoc :: HasDBid NodeType => ContactId -> IsTrash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
236 runViewAuthorsDoc cId t o l order = runOpaQuery $ filterWith o l order $ viewAuthorsDoc cId t ntId
237 where
238 ntId = NodeDocument
239
240 -- TODO add delete ?
241 viewAuthorsDoc :: HasDBid NodeType => ContactId -> IsTrash -> NodeType -> Query FacetDocRead
242 viewAuthorsDoc cId _ nt = proc () -> do
243 (doc,(_,(_,(_,contact')))) <- queryAuthorsDoc -< ()
244
245 {-nn <- queryNodeNodeTable -< ()
246 restrict -< nn_node1_id nn .== _node_id doc
247 -- restrict -< nn_delete nn .== (pgBool t)
248 -}
249
250 restrict -< _node_id contact' .== (toNullable $ pgNodeId cId)
251 restrict -< _node_typename doc .== (pgInt4 $ toDBid nt)
252
253 returnA -< FacetDoc (_node_id doc)
254 (_node_date doc)
255 (_node_name doc)
256 (_node_hyperdata doc)
257 (toNullable $ pgInt4 1)
258 (toNullable $ pgDouble 1)
259 (toNullable $ pgDouble 1)
260
261 queryAuthorsDoc :: Query (NodeRead, (NodeNodeNgramsReadNull, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull))))
262 queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNodeNgramsTable queryNgramsTable queryNodeNodeNgramsTable queryNodeTable cond12 cond23 cond34 cond45
263 where
264 cond12 :: (NodeNodeNgramsRead, NodeRead) -> Column PGBool
265 cond12 (nodeNgram, doc) = _node_id doc
266 .== _nnng_node1_id nodeNgram
267
268 cond23 :: (NgramsRead, (NodeNodeNgramsRead, NodeReadNull)) -> Column PGBool
269 cond23 (ngrams', (nodeNgram, _)) = ngrams'^.ngrams_id
270 .== _nnng_ngrams_id nodeNgram
271
272 cond34 :: (NodeNodeNgramsRead, (NgramsRead, (NodeNodeNgramsReadNull, NodeReadNull))) -> Column PGBool
273 cond34 (nodeNgram2, (ngrams', (_,_)))= ngrams'^.ngrams_id .== _nnng_ngrams_id nodeNgram2
274
275 cond45 :: (NodeRead, (NodeNodeNgramsRead, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull)))) -> Column PGBool
276 cond45 (contact', (nodeNgram2', (_, (_,_)))) = _node_id contact' .== _nnng_node1_id nodeNgram2'
277
278 --}
279 ------------------------------------------------------------------------
280
281 -- TODO-SECURITY check
282 runViewDocuments :: HasDBid NodeType
283 => CorpusId
284 -> IsTrash
285 -> Maybe Offset
286 -> Maybe Limit
287 -> Maybe OrderBy
288 -> Maybe Text
289 -> Cmd err [FacetDoc]
290 runViewDocuments cId t o l order query = do
291 runOpaQuery $ filterWith o l order sqlQuery
292 where
293 ntId = toDBid NodeDocument
294 sqlQuery = viewDocuments cId t ntId query
295
296 runCountDocuments :: HasDBid NodeType => CorpusId -> IsTrash -> Maybe Text -> Cmd err Int
297 runCountDocuments cId t mQuery = do
298 runCountOpaQuery sqlQuery
299 where
300 sqlQuery = viewDocuments cId t (toDBid NodeDocument) mQuery
301
302
303 viewDocuments :: CorpusId
304 -> IsTrash
305 -> NodeTypeId
306 -> Maybe Text
307 -> Query FacetDocRead
308 viewDocuments cId t ntId mQuery = proc () -> do
309 n <- queryNodeTable -< ()
310 nn <- queryNodeNodeTable -< ()
311 restrict -< n^.node_id .== nn^.nn_node2_id
312 restrict -< nn^.nn_node1_id .== (pgNodeId cId)
313 restrict -< n^.node_typename .== (pgInt4 ntId)
314 restrict -< if t then nn^.nn_category .== (pgInt4 0)
315 else nn^.nn_category .>= (pgInt4 1)
316
317 let query = (fromMaybe "" mQuery)
318 iLikeQuery = T.intercalate "" ["%", query, "%"]
319 restrict -< (n^.node_name) `ilike` (pgStrictText iLikeQuery)
320
321 returnA -< FacetDoc (_node_id n)
322 (_node_date n)
323 (_node_name n)
324 (_node_hyperdata n)
325 (toNullable $ nn^.nn_category)
326 (toNullable $ nn^.nn_score)
327 (toNullable $ nn^.nn_score)
328
329 ------------------------------------------------------------------------
330 filterWith :: (PGOrd date, PGOrd title, PGOrd category, PGOrd score, hyperdata ~ Column SqlJsonb) =>
331 Maybe Gargantext.Core.Types.Offset
332 -> Maybe Gargantext.Core.Types.Limit
333 -> Maybe OrderBy
334 -> Select (Facet id (Column date) (Column title) hyperdata (Column category) ngramCount (Column score))
335 -> Select (Facet id (Column date) (Column title) hyperdata (Column category) ngramCount (Column score))
336 filterWith o l order q = limit' l $ offset' o $ orderBy (orderWith order) q
337
338
339 orderWith :: (PGOrd b1, PGOrd b2, PGOrd b3)
340 => Maybe OrderBy
341 -> Order (Facet id (Column b1) (Column b2) (Column SqlJsonb) (Column b3) ngramCount score)
342 orderWith (Just DateAsc) = asc facetDoc_created
343 orderWith (Just DateDesc) = desc facetDoc_created
344
345 orderWith (Just TitleAsc) = asc facetDoc_title
346 orderWith (Just TitleDesc) = desc facetDoc_title
347
348 orderWith (Just ScoreAsc) = asc facetDoc_category
349 orderWith (Just ScoreDesc) = desc facetDoc_category
350
351 orderWith (Just SourceAsc) = asc facetDoc_source
352 orderWith (Just SourceDesc) = desc facetDoc_source
353
354 orderWith _ = asc facetDoc_created
355
356 facetDoc_source :: PGIsJson a
357 => Facet id created title (Column a) favorite ngramCount score
358 -> Column (Nullable PGText)
359 facetDoc_source x = toNullable (facetDoc_hyperdata x) .->> pgString "source"