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