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