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