1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
{-|
Module : Gargantext.Database.Query.Facet
Description : Main requests of Node to the database
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
------------------------------------------------------------------------
module Gargantext.Database.Query.Facet
( runViewAuthorsDoc
, runViewDocuments
-- , viewDocuments'
, runCountDocuments
, filterWith
, Category
, Score
, Title
, Pair(..)
, Facet(..)
, FacetDoc
, FacetDocRead
, FacetPaired(..)
, FacetPairedRead
, FacetPairedReadNull
, FacetPairedReadNullAgg
, OrderBy(..)
)
where
import Control.Arrow (returnA, (>>>))
import Control.Lens ((^.))
import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson.TH (deriveJSON)
--import qualified Database.PostgreSQL.Simple as DPS
--import Database.PostgreSQL.Simple.SqlQQ (sql)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Data.Swagger
import qualified Data.Text as T
import Data.Time (UTCTime)
import Data.Time.Segment (jour)
import Opaleye
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, 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.Context
import Gargantext.Database.Schema.Context
import Gargantext.Database.Query.Table.NodeContext
import Gargantext.Database.Query.Table.ContextNodeNgrams
import Gargantext.Database.Prelude
import Gargantext.Database.Schema.Node
import Gargantext.Prelude (printDebug)
------------------------------------------------------------------------
-- | DocFacet
-- data Facet = FacetDoc | FacetSources | FacetAuthors | FacetTerms
-- deriving (Show, Generic)
--instance FromJSON Facet
--instance ToJSON Facet
type Category = Int
type Score = Double
type Title = Text
-- TODO remove Title
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 category ngramCount score =
FacetDoc { facetDoc_id :: id
, facetDoc_created :: created
, facetDoc_title :: title
, facetDoc_hyperdata :: hyperdata
, facetDoc_category :: category
, facetDoc_ngramCount :: ngramCount
, facetDoc_score :: score
} 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 (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 =
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
, 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 (FacetPaired id date hyperdata score) where
arbitrary = FacetPaired <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
type FacetPairedRead = FacetPaired (Column SqlInt4 )
(Column SqlTimestamptz)
(Column SqlJsonb )
(Column SqlInt4 )
type FacetPairedReadNull = FacetPaired (Column (Nullable SqlInt4) )
(Column (Nullable SqlTimestamptz))
(Column (Nullable SqlJsonb) )
(Column (Nullable SqlInt4) )
type FacetPairedReadNullAgg = FacetPaired (Aggregator (Column (Nullable SqlInt4) )
(Column (Nullable SqlInt4) )
)
(Aggregator (Column (Nullable SqlTimestamptz))
(Column (Nullable SqlTimestamptz))
)
(Aggregator (Column (Nullable SqlJsonb) )
(Column (Nullable SqlJsonb) )
)
(Aggregator (Column (Nullable SqlInt4) )
(Column (Nullable SqlInt4) )
)
-- | JSON instance
$(deriveJSON (unPrefix "facetDoc_") ''Facet)
-- | Documentation instance
instance ToSchema FacetDoc where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "facetDoc_")
-- | Mock and Quickcheck instances
instance Arbitrary FacetDoc where
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
-- | Database instances
$(makeAdaptorAndInstance "pFacetDoc" ''Facet)
-- $(makeLensesWith abbreviatedFields ''Facet)
type FacetDocRead = Facet (Column SqlInt4 )
(Column SqlTimestamptz)
(Column SqlText )
(Column SqlJsonb )
(Column (Nullable SqlInt4)) -- Category
(Column (Nullable SqlFloat8)) -- Ngrams Count
(Column (Nullable SqlFloat8)) -- Score
-----------------------------------------------------------------------
-----------------------------------------------------------------------
data OrderBy = DateAsc | DateDesc
| TitleAsc | TitleDesc
| ScoreDesc | ScoreAsc
| SourceAsc | SourceDesc
deriving (Generic, Enum, Bounded, Read, Show)
instance FromHttpApiData OrderBy
where
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 ToHttpApiData OrderBy where
toUrlPiece = T.pack . show
instance ToParamSchema OrderBy
instance FromJSON OrderBy
instance ToJSON OrderBy
instance ToSchema OrderBy
instance Arbitrary OrderBy
where
arbitrary = elements [minBound..maxBound]
-- TODO-SECURITY check
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 :: HasDBid NodeType
=> ContactId
-> IsTrash
-> NodeType
-> Select FacetDocRead
viewAuthorsDoc cId _ nt = proc () -> do
(doc,(_,(_,(_,contact')))) <- queryAuthorsDoc -< ()
restrict -< _node_id contact' .== (toNullable $ pgNodeId cId)
restrict -< _node_typename doc .== (sqlInt4 $ toDBid nt)
returnA -< FacetDoc { facetDoc_id = _node_id doc
, facetDoc_created = _node_date doc
, facetDoc_title = _node_name doc
, facetDoc_hyperdata = _node_hyperdata doc
, facetDoc_category = toNullable $ sqlInt4 1
, facetDoc_ngramCount = toNullable $ sqlDouble 1
, facetDoc_score = toNullable $ sqlDouble 1 }
queryAuthorsDoc :: Select (NodeRead, (ContextNodeNgramsReadNull, (NgramsReadNull, (ContextNodeNgramsReadNull, NodeReadNull))))
queryAuthorsDoc = leftJoin5 queryNodeTable queryContextNodeNgramsTable queryNgramsTable queryContextNodeNgramsTable queryNodeTable cond12 cond23 cond34 cond45
where
cond12 :: (ContextNodeNgramsRead, NodeRead) -> Column SqlBool
cond12 (nodeNgram, doc) = _node_id doc
.== _cnng_context_id nodeNgram
cond23 :: (NgramsRead, (ContextNodeNgramsRead, NodeReadNull)) -> Column SqlBool
cond23 (ngrams', (nodeNgram, _)) = ngrams'^.ngrams_id
.== _cnng_ngrams_id nodeNgram
cond34 :: (ContextNodeNgramsRead, (NgramsRead, (ContextNodeNgramsReadNull, NodeReadNull))) -> Column SqlBool
cond34 (nodeNgram2, (ngrams', (_,_)))= ngrams'^.ngrams_id .== _cnng_ngrams_id nodeNgram2
cond45 :: (NodeRead, (ContextNodeNgramsRead, (NgramsReadNull, (ContextNodeNgramsReadNull, NodeReadNull)))) -> Column SqlBool
cond45 (contact', (nodeNgram2', (_, (_,_)))) = _node_id contact' .== _cnng_context_id nodeNgram2'
------------------------------------------------------------------------
-- TODO-SECURITY check
runViewDocuments :: HasDBid NodeType
=> CorpusId
-> IsTrash
-> Maybe Offset
-> Maybe Limit
-> Maybe OrderBy
-> Maybe Text
-> Cmd err [FacetDoc]
runViewDocuments cId t o l order query = do
printDebug "[runViewDocuments] sqlQuery" $ showSql sqlQuery
runOpaQuery $ filterWith o l order sqlQuery
where
sqlQuery = viewDocuments cId t (toDBid NodeDocument) query
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
-> Maybe Text
-> Select FacetDocRead
viewDocuments cId t ntId mQuery = viewDocumentsQuery cId t ntId mQuery >>> proc (c, nc) -> do
returnA -< FacetDoc { facetDoc_id = _cs_id c
, facetDoc_created = _cs_date c
, facetDoc_title = _cs_name c
, facetDoc_hyperdata = _cs_hyperdata c
, facetDoc_category = toNullable $ nc^.nc_category
, facetDoc_ngramCount = toNullable $ nc^.nc_score
, facetDoc_score = toNullable $ nc^.nc_score
}
viewDocumentsQuery :: CorpusId
-> IsTrash
-> NodeTypeId
-> Maybe Text
-> Select (ContextSearchRead, NodeContextRead)
viewDocumentsQuery cId t ntId mQuery = proc () -> do
c <- queryContextSearchTable -< ()
nc <- queryNodeContextTable -< ()
restrict -< c^.cs_id .== nc^.nc_context_id
restrict -< nc^.nc_node_id .== (pgNodeId cId)
restrict -< c^.cs_typename .== (sqlInt4 ntId)
restrict -< if t then nc^.nc_category .== (sqlInt4 0)
else nc^.nc_category .>= (sqlInt4 1)
let
query = (fromMaybe "" mQuery)
iLikeQuery = T.intercalate "" ["%", query, "%"]
abstractLHS h = fromNullable (sqlStrictText "")
$ toNullable h .->> (sqlStrictText "abstract")
restrict -<
if query == "" then sqlBool True
else ((c^.cs_name) `ilike` (sqlStrictText iLikeQuery))
.|| ((abstractLHS (c^.cs_hyperdata)) `ilike` (sqlStrictText iLikeQuery))
returnA -< (c, nc)
------------------------------------------------------------------------
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 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 :: (SqlOrd b1, SqlOrd b2, SqlOrd b3, SqlOrd b4)
=> Maybe OrderBy
-> 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_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 :: SqlIsJson a
=> Facet id created title (Column a) favorite ngramCount score
-> Column (Nullable SqlText)
facetDoc_source x = toNullable (facetDoc_hyperdata x) .->> sqlString "source"