]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Database/Facet.hs
merge conflict resolved
[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 <- arbitraryHyperdataDocuments
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 type Trash = Bool
171 data OrderBy = DateAsc | DateDesc
172 | TitleAsc | TitleDesc
173 | ScoreDesc | ScoreAsc
174 deriving (Generic, Enum, Bounded, Read, Show)
175 -- | NgramCoun
176
177 instance FromHttpApiData OrderBy
178 where
179 parseUrlPiece "DateAsc" = pure DateAsc
180 parseUrlPiece "DateDesc" = pure DateDesc
181 parseUrlPiece "TitleAsc" = pure TitleAsc
182 parseUrlPiece "TitleDesc" = pure TitleDesc
183 parseUrlPiece "ScoreAsc" = pure ScoreAsc
184 parseUrlPiece "ScoreDesc" = pure ScoreDesc
185 parseUrlPiece _ = Left "Unexpected value of OrderBy"
186
187 instance ToParamSchema OrderBy
188 instance FromJSON OrderBy
189 instance ToJSON OrderBy
190 instance ToSchema OrderBy
191 instance Arbitrary OrderBy
192 where
193 arbitrary = elements [minBound..maxBound]
194
195
196 runViewAuthorsDoc :: ContactId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
197 runViewAuthorsDoc cId t o l order = runOpaQuery $ filterWith o l order $ viewAuthorsDoc cId t ntId
198 where
199 ntId = NodeDocument
200
201 -- TODO add delete ?
202 viewAuthorsDoc :: ContactId -> Trash -> NodeType -> Query FacetDocRead
203 viewAuthorsDoc cId _ nt = proc () -> do
204 (doc,(_,(_,(_,contact)))) <- queryAuthorsDoc -< ()
205
206 {-nn <- queryNodeNodeTable -< ()
207 restrict -< nn_node1_id nn .== _node_id doc
208 -- restrict -< nn_delete nn .== (pgBool t)
209 -}
210
211 restrict -< _node_id contact .== (toNullable $ pgNodeId cId)
212 restrict -< _node_typename doc .== (pgInt4 $ nodeTypeId nt)
213
214 returnA -< FacetDoc (_node_id doc) (_node_date doc) (_node_name doc) (_node_hyperdata doc) (pgBool True) (pgInt4 1)
215
216 queryAuthorsDoc :: Query (NodeRead, (NodeNgramReadNull, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull))))
217 queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable queryNodeNgramTable queryNodeTable cond12 cond23 cond34 cond45
218 where
219 cond12 :: (NodeNgramRead, NodeRead) -> Column PGBool
220 cond12 (nodeNgram, doc) = _node_id doc
221 .== nng_node_id nodeNgram
222
223 cond23 :: (NgramsRead, (NodeNgramRead, NodeReadNull)) -> Column PGBool
224 cond23 (ngrams, (nodeNgram, _)) = ngrams_id ngrams
225 .== nng_ngrams_id nodeNgram
226
227 cond34 :: (NodeNgramRead, (NgramsRead, (NodeNgramReadNull, NodeReadNull))) -> Column PGBool
228 cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams_id ngrams .== nng_ngrams_id nodeNgram2
229
230 cond45 :: (NodeRead, (NodeNgramRead, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull)))) -> Column PGBool
231 cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id contact .== nng_node_id nodeNgram2
232
233
234 ------------------------------------------------------------------------
235
236 runViewDocuments :: CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
237 runViewDocuments cId t o l order =
238 runOpaQuery $ filterWith o l order $ viewDocuments cId t ntId
239 where
240 ntId = nodeTypeId NodeDocument
241
242 viewDocuments :: CorpusId -> Trash -> NodeTypeId -> Query FacetDocRead
243 viewDocuments cId t ntId = proc () -> do
244 n <- queryNodeTable -< ()
245 nn <- queryNodeNodeTable -< ()
246 restrict -< _node_id n .== nn_node2_id nn
247 restrict -< nn_node1_id nn .== (pgNodeId cId)
248 restrict -< _node_typename n .== (pgInt4 ntId)
249 restrict -< nn_delete nn .== (pgBool t)
250 returnA -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (nn_favorite nn) (pgInt4 1)
251
252
253 ------------------------------------------------------------------------
254 filterWith :: (PGOrd date, PGOrd title, PGOrd score) =>
255 Maybe Gargantext.Core.Types.Offset
256 -> Maybe Gargantext.Core.Types.Limit
257 -> Maybe OrderBy
258 -> Select (Facet id (Column date) (Column title) hyperdata (Column score) ngramCount)
259 -> Select (Facet id (Column date) (Column title) hyperdata (Column score) ngramCount)
260 filterWith o l order q = limit' l $ offset' o $ orderBy (orderWith order) q
261
262
263 orderWith :: (PGOrd b1, PGOrd b2, PGOrd b3) => Maybe OrderBy -> Order (Facet id (Column b1) (Column b2) hyperdata (Column b3) score)
264 orderWith order = case order of
265 (Just DateAsc) -> asc facetDoc_created
266
267 (Just TitleAsc) -> asc facetDoc_title
268 (Just TitleDesc) -> desc facetDoc_title
269
270 (Just ScoreAsc) -> asc facetDoc_favorite
271 (Just ScoreDesc) -> desc facetDoc_favorite
272 _ -> desc facetDoc_created
273