]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Database/Facet.hs
More refactoring
[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 ------------------------------------------------------------------------
27 module Gargantext.Database.Facet
28 where
29 ------------------------------------------------------------------------
30 import Control.Arrow (returnA)
31 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
32 import Data.Aeson (FromJSON, ToJSON)
33 import Data.Aeson.TH (deriveJSON)
34 import Data.Either(Either(Left))
35 import Data.Maybe (Maybe)
36 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
37 import Data.Swagger
38 import Data.Text (Text)
39 import Data.Time (UTCTime)
40 import Data.Time.Segment (jour)
41 import GHC.Generics (Generic)
42 import Gargantext.Core.Types
43 import Gargantext.Core.Utils.Prefix (unPrefix)
44 import Gargantext.Database.Config (nodeTypeId)
45 import Gargantext.Database.Schema.Ngrams
46 import Gargantext.Database.Schema.Node
47 import Gargantext.Database.Schema.NodeNgram
48 import Gargantext.Database.Schema.NodeNode
49 import Gargantext.Database.Utils
50 import Gargantext.Database.Queries.Join
51 import Gargantext.Database.Queries.Filter
52 import Opaleye
53 import Prelude hiding (null, id, map, sum, not, read)
54 import Servant.API
55 import Test.QuickCheck (elements)
56 import Test.QuickCheck.Arbitrary
57 import qualified Opaleye.Internal.Unpackspec()
58
59 ------------------------------------------------------------------------
60 -- | DocFacet
61
62 -- data Facet = FacetDoc | FacetSources | FacetAuthors | FacetTerms
63 -- deriving (Show, Generic)
64 --instance FromJSON Facet
65 --instance ToJSON Facet
66
67 type Favorite = Bool
68 type Title = Text
69
70 type FacetDoc = Facet NodeId UTCTime Title HyperdataDocument Favorite Int
71 type FacetSources = FacetDoc
72 type FacetAuthors = FacetDoc
73 type FacetTerms = FacetDoc
74
75
76 data Facet id created title hyperdata favorite ngramCount =
77 FacetDoc { facetDoc_id :: id
78 , facetDoc_created :: created
79 , facetDoc_title :: title
80 , facetDoc_hyperdata :: hyperdata
81 , facetDoc_favorite :: favorite
82 , facetDoc_ngramCount :: ngramCount
83 } deriving (Show, Generic)
84 {- | TODO after demo
85 data Facet id date hyperdata score =
86 FacetDoc { facetDoc_id :: id
87 , facetDoc_date :: date
88 , facetDoc_hyperdata :: hyperdata
89 , facetDoc_score :: score
90 } deriving (Show, Generic)
91 -}
92
93 data Pair i l = Pair {_p_id :: i
94 ,_p_label :: l
95 } deriving (Show, Generic)
96 $(deriveJSON (unPrefix "_p_") ''Pair)
97 $(makeAdaptorAndInstance "pPair" ''Pair)
98
99 instance (ToSchema i, ToSchema l) => ToSchema (Pair i l) where
100 declareNamedSchema =
101 genericDeclareNamedSchema
102 defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 3 fieldLabel}
103 instance (Arbitrary i, Arbitrary l) => Arbitrary (Pair i l) where
104 arbitrary = Pair <$> arbitrary <*> arbitrary
105
106 data FacetPaired id date hyperdata score pairs =
107 FacetPaired {_fp_id :: id
108 ,_fp_date :: date
109 ,_fp_hyperdata :: hyperdata
110 ,_fp_score :: score
111 ,_fp_pairs :: pairs
112 } deriving (Show, Generic)
113 $(deriveJSON (unPrefix "_fp_") ''FacetPaired)
114 $(makeAdaptorAndInstance "pFacetPaired" ''FacetPaired)
115
116 instance (ToSchema id, ToSchema date, ToSchema hyperdata, ToSchema pairs, ToSchema score) => ToSchema (FacetPaired id date hyperdata score pairs) where
117 declareNamedSchema =
118 genericDeclareNamedSchema
119 defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
120
121 instance ( Arbitrary id
122 , Arbitrary date
123 , Arbitrary hyperdata
124 , Arbitrary score
125 , Arbitrary pairs
126 ) => Arbitrary (FacetPaired id date hyperdata score pairs) where
127 arbitrary = FacetPaired <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
128
129 --{-
130 type FacetPairedRead = FacetPaired (Column PGInt4 )
131 (Column PGTimestamptz)
132 (Column PGJsonb )
133 (Column PGInt4 )
134 (Pair (Column (Nullable PGInt4)) (Column (Nullable PGText)))
135 --}
136
137
138
139 -- | JSON instance
140 $(deriveJSON (unPrefix "facetDoc_") ''Facet)
141
142 -- | Documentation instance
143 instance ToSchema FacetDoc
144
145 -- | Mock and Quickcheck instances
146 instance Arbitrary FacetDoc where
147 arbitrary = elements [ FacetDoc id' (jour year 01 01) t hp fav ngramCount
148 | id' <- [1..10]
149 , year <- [1990..2000]
150 , t <- ["title", "another title"]
151 , hp <- hyperdataDocuments
152 , fav <- [True, False]
153 , ngramCount <- [3..100]
154 ]
155
156 -- Facets / Views for the Front End
157 -- | Database instances
158 $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
159 $(makeLensesWith abbreviatedFields ''Facet)
160
161 type FacetDocRead = Facet (Column PGInt4 )
162 (Column PGTimestamptz)
163 (Column PGText )
164 (Column PGJsonb )
165 (Column PGBool)
166 (Column PGInt4 )
167
168 -----------------------------------------------------------------------
169
170 data FacetChart = FacetChart { facetChart_time :: UTCTime'
171 , facetChart_count :: Double
172 }
173 deriving (Show, Generic)
174 $(deriveJSON (unPrefix "facetChart_") ''FacetChart)
175 instance ToSchema FacetChart
176
177 instance Arbitrary FacetChart where
178 arbitrary = FacetChart <$> arbitrary <*> arbitrary
179
180 -----------------------------------------------------------------------
181 type Trash = Bool
182 data OrderBy = DateAsc | DateDesc
183 | TitleAsc | TitleDesc
184 | ScoreDesc | ScoreAsc
185 deriving (Generic, Enum, Bounded, Read, Show)
186 -- | NgramCoun
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 _ = Left "Unexpected value of OrderBy"
197
198 instance ToParamSchema OrderBy
199 instance FromJSON OrderBy
200 instance ToJSON OrderBy
201 instance ToSchema OrderBy
202 instance Arbitrary OrderBy
203 where
204 arbitrary = elements [minBound..maxBound]
205
206
207 runViewAuthorsDoc :: ContactId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
208 runViewAuthorsDoc cId t o l order = runOpaQuery $ filterWith o l order $ viewAuthorsDoc cId t ntId
209 where
210 ntId = NodeDocument
211
212 -- TODO add delete ?
213 viewAuthorsDoc :: ContactId -> Trash -> NodeType -> Query FacetDocRead
214 viewAuthorsDoc cId _ nt = proc () -> do
215 (doc,(_,(_,(_,contact)))) <- queryAuthorsDoc -< ()
216
217 {-nn <- queryNodeNodeTable -< ()
218 restrict -< nodeNode_node1_id nn .== _node_id doc
219 -- restrict -< nodeNode_delete nn .== (pgBool t)
220 -}
221
222 restrict -< _node_id contact .== (toNullable $ pgNodeId cId)
223 restrict -< _node_typename doc .== (pgInt4 $ nodeTypeId nt)
224
225 returnA -< FacetDoc (_node_id doc) (_node_date doc) (_node_name doc) (_node_hyperdata doc) (pgBool True) (pgInt4 1)
226
227 queryAuthorsDoc :: Query (NodeRead, (NodeNgramReadNull, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull))))
228 queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable queryNodeNgramTable queryNodeTable cond12 cond23 cond34 cond45
229 where
230 cond12 :: (NodeNgramRead, NodeRead) -> Column PGBool
231 cond12 (nodeNgram, doc) = _node_id doc
232 .== _nn_node_id nodeNgram
233
234 cond23 :: (NgramsRead, (NodeNgramRead, NodeReadNull)) -> Column PGBool
235 cond23 (ngrams, (nodeNgram, _)) = ngrams_id ngrams
236 .== _nn_ngrams_id nodeNgram
237
238 cond34 :: (NodeNgramRead, (NgramsRead, (NodeNgramReadNull, NodeReadNull))) -> Column PGBool
239 cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams_id ngrams .== _nn_ngrams_id nodeNgram2
240
241 cond45 :: (NodeRead, (NodeNgramRead, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull)))) -> Column PGBool
242 cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id contact .== _nn_node_id nodeNgram2
243
244
245 ------------------------------------------------------------------------
246
247 runViewDocuments :: CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
248 runViewDocuments cId t o l order =
249 runOpaQuery $ filterWith o l order $ viewDocuments cId t ntId
250 where
251 ntId = nodeTypeId NodeDocument
252
253 viewDocuments :: CorpusId -> Trash -> NodeTypeId -> Query FacetDocRead
254 viewDocuments cId t ntId = proc () -> do
255 n <- queryNodeTable -< ()
256 nn <- queryNodeNodeTable -< ()
257 restrict -< _node_id n .== nodeNode_node2_id nn
258 restrict -< nodeNode_node1_id nn .== (pgNodeId cId)
259 restrict -< _node_typename n .== (pgInt4 ntId)
260 restrict -< nodeNode_delete nn .== (pgBool t)
261 returnA -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (nodeNode_favorite nn) (pgInt4 1)
262
263
264 ------------------------------------------------------------------------
265 filterWith :: (PGOrd date, PGOrd title, PGOrd score) =>
266 Maybe Gargantext.Core.Types.Offset
267 -> Maybe Gargantext.Core.Types.Limit
268 -> Maybe OrderBy
269 -> Select (Facet id (Column date) (Column title) hyperdata (Column score) ngramCount)
270 -> Select (Facet id (Column date) (Column title) hyperdata (Column score) ngramCount)
271 filterWith o l order q = limit' l $ offset' o $ orderBy (orderWith order) q
272
273
274 orderWith :: (PGOrd b1, PGOrd b2, PGOrd b3) => Maybe OrderBy -> Order (Facet id (Column b1) (Column b2) hyperdata (Column b3) score)
275 orderWith order = case order of
276 (Just DateAsc) -> asc facetDoc_created
277
278 (Just TitleAsc) -> asc facetDoc_title
279 (Just TitleDesc) -> desc facetDoc_title
280
281 (Just ScoreAsc) -> asc facetDoc_favorite
282 (Just ScoreDesc) -> desc facetDoc_favorite
283 _ -> desc facetDoc_created
284