]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Database/Facet.hs
[COUNT] unprefix.
[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 TemplateHaskell #-}
17 {-# LANGUAGE FlexibleContexts #-}
18 {-# LANGUAGE FlexibleInstances #-}
19 {-# LANGUAGE MultiParamTypeClasses #-}
20 {-# LANGUAGE FunctionalDependencies #-}
21 {-# LANGUAGE NoMonomorphismRestriction #-}
22
23 ------------------------------------------------------------------------
24 module Gargantext.Database.Facet where
25 ------------------------------------------------------------------------
26
27 import Prelude hiding (null, id, map, sum, not)
28 import GHC.Generics (Generic)
29
30 -- import Data.Aeson (Value)
31 import Control.Arrow (returnA)
32 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
33
34 import Data.Aeson.TH (deriveJSON)
35 import Data.Maybe (Maybe)
36 import Data.Profunctor.Product.Default (Default)
37 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
38 import Data.Time (UTCTime)
39 import Data.Time.Segment (jour)
40 import Data.Swagger
41
42 import Database.PostgreSQL.Simple (Connection)
43 import Opaleye
44 import Opaleye.Internal.Join (NullMaker)
45 import qualified Opaleye.Internal.Unpackspec()
46
47 import Test.QuickCheck.Arbitrary
48 import Test.QuickCheck (elements)
49
50 import Gargantext.Types
51 import Gargantext.Types.Node (NodeType)
52 import Gargantext.Database.NodeNode
53 import Gargantext.Database.NodeNodeNgram
54 import Gargantext.Database.Node
55 import Gargantext.Database.Queries
56 import Gargantext.Utils.Prefix (unPrefix)
57 -- import Gargantext.Database.NodeNgram
58
59 ------------------------------------------------------------------------
60 ------------------------------------------------------------------------
61
62 -- | DocFacet
63 type FacetDoc = Facet NodeId UTCTime HyperdataDocument Bool -- Double
64
65 data Facet id created hyperdata favorite =
66 FacetDoc { facetDoc_id :: id
67 , facetDoc_created :: created
68 , facetDoc_hyperdata :: hyperdata
69 , facetDoc_favorite :: favorite
70 } deriving (Show, Generic)
71 $(deriveJSON (unPrefix "facetDoc_") ''Facet)
72
73 instance Arbitrary FacetDoc where
74 arbitrary = elements [ FacetDoc id' (jour year 01 01) hp fav
75 | id' <- [ 1..10 ]
76 , year <- [1990..2000 ]
77 , fav <- [True, False]
78 , hp <- hyperdataDocuments
79 ]
80
81 instance ToSchema FacetDoc
82
83 -- Facets / Views for the Front End
84 type FacetDocRead = Facet (Column PGInt4 )
85 (Column PGTimestamptz)
86 (Column PGJsonb )
87 (Column PGBool ) -- (Column PGFloat8)
88
89 $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
90 $(makeLensesWith abbreviatedFields ''Facet)
91
92 ------------------------------------------------------------------------
93 type FacetDoc' = Facet' NodeId UTCTime HyperdataDocument Bool Int
94
95 data Facet' id created hyperdata favorite ngramCount =
96 FacetDoc' { facetDocP_id :: id
97 , facetDocP_created :: created
98 , facetDocP_hyperdata :: hyperdata
99 , facetDocP_favorite :: favorite
100 , facetDocP_ngramCount :: ngramCount
101 } deriving (Show)
102 $(deriveJSON (unPrefix "facetDocP_") ''Facet')
103
104 instance Arbitrary FacetDoc' where
105 arbitrary = elements [ FacetDoc' id' (jour year 01 01) hp fav ngramCount
106 | id' <- [1..10]
107 , year <- [1990..2000]
108 , hp <- hyperdataDocuments
109 , fav <- [True, False]
110 , ngramCount <- [1..10]
111 ]
112
113 -- Facets / Views for the Front End
114 type FacetDocRead' = Facet' (Column PGInt4 )
115 (Column PGTimestamptz)
116 (Column PGJsonb )
117 (Column PGBool )
118 (Column PGInt4 )
119
120 $(makeAdaptorAndInstance "pFacetDocP" ''Facet')
121 $(makeLensesWith abbreviatedFields ''Facet')
122
123 ------------------------------------------------------------------------
124
125
126 getDocFacet :: Connection -> Int -> Maybe NodeType
127 -> Maybe Offset -> Maybe Limit
128 -> IO [FacetDoc]
129 getDocFacet conn parentId nodeType maybeOffset maybeLimit =
130 runQuery conn $ selectDocFacet parentId nodeType maybeOffset maybeLimit
131
132 selectDocFacet :: ParentId -> Maybe NodeType
133 -> Maybe Offset -> Maybe Limit
134 -> Query FacetDocRead
135 selectDocFacet parentId maybeNodeType maybeOffset maybeLimit =
136 limit' maybeLimit $ offset' maybeOffset
137 $ orderBy (asc facetDoc_created)
138 $ selectDocFacet' parentId maybeNodeType
139
140
141 -- | Left join to the favorites
142 nodeNodeLeftJoin :: Query (NodeRead, NodeNodeReadNull)
143 nodeNodeLeftJoin = leftJoin queryNodeTable queryNodeNodeTable (eqNode)
144 where
145 eqNode (Node n1 _ _ _ _ _ _, NodeNode _ n2 _) = ((.==) n1 n2)
146
147
148 nodeNodeLeftJoin' :: (Column (Nullable PGInt4))
149 -> Query (NodeRead, NodeNodeReadNull)
150 nodeNodeLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeTable (eqNode nId)
151 where
152 eqNode n (Node n1 _ _ _ _ _ _, NodeNode n1' n2 _)
153 = foldl (.&&) (pgBool True) [ ((.==) n1 n2)
154 , ((.==) n1' n)
155 ]
156
157 nodeNodeLeftJoin'' :: Query (NodeRead, NodeRead, NodeNodeRead)
158 nodeNodeLeftJoin'' = join3 queryNodeTable queryNodeTable queryNodeNodeTable eqNode
159 where
160 eqNode (Node n1 _ _ _ _ _ _, Node n2 _ _ _ _ _ _, NodeNode n1' n2' _)
161 = foldl (.&&) (pgBool True) [ ((.==) n2 n2')
162 , ((.==) (toNullable n1) n1')
163 ]
164
165 -- | Left join to the ngram count per document
166 nodeNodeNgramLeftJoin :: Query (NodeRead, NodeNodeNgramReadNull)
167 nodeNodeNgramLeftJoin = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode)
168 where
169 eqNode (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' _ _ _) = ((.==) n1 n1')
170
171
172 nodeNodeNgramLeftJoin' :: Column (Nullable PGInt4)
173 -> Query (NodeRead, NodeNodeNgramReadNull)
174 nodeNodeNgramLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode nId)
175 where
176 eqNode nId' (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' n2 _ _)
177 = (.&&) ((.==) n1 n1')
178 ((.==) nId' (toNullable n2))
179
180
181 leftJoin3 :: (Default NullMaker (columnsL1, nullableColumnsR) nullableColumnsR1,
182 Default NullMaker columnsR nullableColumnsR,
183 Default Unpackspec columnsR columnsR,
184 Default Unpackspec nullableColumnsR nullableColumnsR,
185 Default Unpackspec columnsL1 columnsL1,
186 Default Unpackspec columnsL columnsL) =>
187 Query columnsL1 -> Query columnsR -> Query columnsL
188 -> ((columnsL1, columnsR) -> Column PGBool)
189 -> ((columnsL, (columnsL1, nullableColumnsR)) -> Column PGBool)
190 -> Query (columnsL, nullableColumnsR1)
191 leftJoin3 q1 q2 q3 cond12 cond23 = leftJoin q3 (leftJoin q1 q2 cond12) cond23
192
193
194 leftJoin3' :: Query (NodeRead, (NodeReadNull, NodeNodeNgramReadNull))
195 leftJoin3' = leftJoin3 queryNodeTable queryNodeNodeNgramTable queryNodeTable cond12 cond23
196 where
197 cond12 (Node occId _ _ _ _ _ _, NodeNodeNgram occId' _ _ _)
198 = (.==) occId occId'
199
200 cond23 :: (NodeRead, (NodeRead, NodeNodeNgramReadNull)) -> Column PGBool
201 cond23 (Node docId _ _ _ _ _ _, (Node _ _ _ _ _ _ _, NodeNodeNgram _ docId' _ _))
202 = (.||) ((.==) (toNullable docId) docId') (isNull docId')
203
204
205 leftJoin3''' :: Query (NodeRead, (NodeNodeReadNull, NodeReadNull))
206 leftJoin3''' = leftJoin3 queryNodeNodeTable queryNodeTable queryNodeTable cond12 cond23
207 where
208 cond12 (NodeNode favId _ _, Node favId' _ _ _ _ _ _)
209 = (.||) ((.==) favId (toNullable favId')) (isNull $ toNullable favId)
210
211 cond23 :: (NodeRead, (NodeNodeRead, NodeReadNull)) -> Column PGBool
212 cond23 (Node nId _ _ _ _ _ _, (NodeNode _ nId' _, Node _ _ _ _ _ _ _ ))
213 = ((.==) (nId) (nId'))
214
215
216 getDocTest' :: Connection -> IO [FacetDoc']
217 getDocTest' conn = runQuery conn selectDocFacet''
218
219 -- | Building the facet
220 -- selectDocFacet' :: ParentId -> Maybe NodeType -> Query FacetDocRead
221 selectDocFacet'' :: Query FacetDocRead'
222 selectDocFacet'' = proc () -> do
223 (n1,(nn,n2)) <- leftJoin3''' -< ()
224 restrict -< (.&&) (node_parentId n1 .== (toNullable $ pgInt4 347476))
225 (node_typename n1 .== (pgInt4 4))
226
227 restrict -< (.||) (node_typename n2 .== (toNullable $ pgInt4 15))
228 (isNull $ node_typename n2)
229
230 restrict -< (.||) (node_parentId n2 .== (toNullable $ pgInt4 347476))
231 (isNull $ node_parentId n2)
232
233 let isFav = ifThenElse (isNull $ nodeNode_score nn) (pgBool False) (pgBool True)
234 --
235 returnA -< FacetDoc' (node_id n1) (node_date n1) (node_hyperdata n1) (isFav) (pgInt4 1)
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251 selectDocFacet' :: ParentId -> Maybe NodeType -> Query FacetDocRead
252 selectDocFacet' parentId _ = proc () -> do
253 node <- (proc () -> do
254
255 -- Favorite Column
256 -- (Node docId docTypeId _ docParentId _ created docHyperdata, (Node _ favTypeId _ favParentId _ _ _, NodeNode _ docId' _)) <- leftJoin3'' -< ()
257 (Node docId docTypeId _ docParentId _ created docHyperdata, (NodeNode _ docId' _, (Node _ favTypeId _ favParentId _ _ _))) <- leftJoin3''' -< ()
258
259 restrict -< docTypeId .== (pgInt4 15) .&& docParentId .== (toNullable $ pgInt4 parentId)
260
261 -- select nn.score from nodes n left join nodes_nodes nn on n.id = nn.node2_id where n.typename =4;
262 -- Selecting the documents and joining Favorite Node
263
264 restrict -< favParentId .== (toNullable $ pgInt4 parentId) .&& favTypeId .== (toNullable 4)
265
266 -- let docTypeId'' = maybe 0 nodeTypeId (Just Document)
267
268 -- Getting favorite data
269 let isFav = ifThenElse (isNull docId') (pgBool False) (pgBool True)
270 -- Ngram count by document
271 -- Counting the ngram
272 -- (Node occId occTypeId _ _ _ _ _, NodeNode _ _ _ count) <- nodeNodeNgramLeftJoin -< ()
273 -- restrict -< occId .== 347540
274
275 --returnA -< (FacetDoc n_id hyperdata isFav ngramCount)) -< ()
276 returnA -< (FacetDoc docId created docHyperdata isFav)) -< ()
277 returnA -< node
278