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