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
11 {-# OPTIONS_GHC -fno-warn-orphans #-}
12 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
14 {-# LANGUAGE Arrows #-}
15 {-# LANGUAGE DeriveGeneric #-}
16 {-# LANGUAGE TemplateHaskell #-}
17 {-# LANGUAGE FlexibleContexts #-}
18 {-# LANGUAGE FlexibleInstances #-}
19 {-# LANGUAGE MultiParamTypeClasses #-}
20 {-# LANGUAGE FunctionalDependencies #-}
21 {-# LANGUAGE NoMonomorphismRestriction #-}
23 module Gargantext.Database.Facet where
25 import Prelude hiding (null, id, map, sum, not)
27 import Gargantext.Types
28 import Gargantext.Types.Node (NodeType)
29 import Gargantext.Database.NodeNode
30 import Gargantext.Database.NodeNodeNgram
31 import Gargantext.Database.Node
32 import Gargantext.Database.Queries
33 import Gargantext.Utils.Prefix (unPrefix)
34 -- import Gargantext.Database.NodeNgram
36 -- import Data.Aeson (Value)
37 import Data.Aeson.TH (deriveJSON)
38 import Control.Arrow (returnA)
39 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
40 import Data.Maybe (Maybe)
41 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
42 import Data.Time (UTCTime)
43 import Database.PostgreSQL.Simple (Connection)
45 import Opaleye.Internal.Join (NullMaker)
47 import qualified Opaleye.Internal.Unpackspec()
48 import Data.Profunctor.Product.Default (Default)
50 import Data.Time.Segment (jour)
52 import Test.QuickCheck.Arbitrary
53 import Test.QuickCheck (elements)
57 ------------------------------------------------------------------------
59 type FacetDoc = Facet NodeId UTCTime HyperdataDocument Bool -- Double
61 data Facet id created hyperdata favorite =
62 FacetDoc { facetDoc_id :: id
63 , facetDoc_created :: created
64 , facetDoc_hyperdata :: hyperdata
65 , facetDoc_favorite :: favorite
67 $(deriveJSON (unPrefix "facetDoc_") ''Facet)
69 instance Arbitrary FacetDoc where
70 arbitrary = elements [ FacetDoc id' (jour year 01 01) hp fav
72 , year <- [1990..2000]
73 , fav <- [True, False]
74 , hp <- hyperdataDocuments
77 -- Facets / Views for the Front End
78 type FacetDocRead = Facet (Column PGInt4) (Column PGTimestamptz) (Column PGJsonb) (Column PGBool) -- (Column PGFloat8)
80 $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
81 $(makeLensesWith abbreviatedFields ''Facet)
83 ------------------------------------------------------------------------
84 type FacetDoc' = Facet' NodeId UTCTime HyperdataDocument Bool Int
86 data Facet' id created hyperdata favorite ngramCount =
87 FacetDoc' { facetDocP_id :: id
88 , facetDocP_created :: created
89 , facetDocP_hyperdata :: hyperdata
90 , facetDocP_favorite :: favorite
91 , facetDocP_ngramCount :: ngramCount
93 $(deriveJSON (unPrefix "facetDocP_") ''Facet')
95 instance Arbitrary FacetDoc' where
96 arbitrary = elements [ FacetDoc' id' (jour year 01 01) hp fav ngramCount
98 , year <- [1990..2000]
99 , hp <- hyperdataDocuments
100 , fav <- [True, False]
101 , ngramCount <- [1..10]
104 -- Facets / Views for the Front End
105 type FacetDocRead' = Facet' (Column PGInt4 )
106 (Column PGTimestamptz)
111 $(makeAdaptorAndInstance "pFacetDocP" ''Facet')
112 $(makeLensesWith abbreviatedFields ''Facet')
114 ------------------------------------------------------------------------
117 getDocFacet :: Connection -> Int -> Maybe NodeType -> Maybe Offset -> Maybe Limit -> IO [FacetDoc]
118 getDocFacet conn parentId nodeType maybeOffset maybeLimit =
119 runQuery conn $ selectDocFacet parentId nodeType maybeOffset maybeLimit
121 selectDocFacet :: ParentId -> Maybe NodeType -> Maybe Offset -> Maybe Limit -> Query FacetDocRead
122 selectDocFacet parentId maybeNodeType maybeOffset maybeLimit =
123 limit' maybeLimit $ offset' maybeOffset $ orderBy (asc facetDoc_created) $ selectDocFacet' parentId maybeNodeType
126 -- | Left join to the favorites
127 nodeNodeLeftJoin :: Query (NodeRead, NodeNodeReadNull)
128 nodeNodeLeftJoin = leftJoin queryNodeTable queryNodeNodeTable (eqNode)
130 eqNode (Node n1 _ _ _ _ _ _, NodeNode _ n2 _) = ((.==) n1 n2)
133 nodeNodeLeftJoin' :: (Column (Nullable PGInt4))
134 -> Query (NodeRead, NodeNodeReadNull)
135 nodeNodeLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeTable (eqNode nId)
137 eqNode n (Node n1 _ _ _ _ _ _, NodeNode n1' n2 _)
138 = foldl (.&&) (pgBool True) [ ((.==) n1 n2)
142 nodeNodeLeftJoin'' :: Query (NodeRead, NodeRead, NodeNodeRead)
143 nodeNodeLeftJoin'' = join3 queryNodeTable queryNodeTable queryNodeNodeTable eqNode
145 eqNode (Node n1 _ _ _ _ _ _, Node n2 _ _ _ _ _ _, NodeNode n1' n2' _)
146 = foldl (.&&) (pgBool True) [ ((.==) n2 n2')
147 , ((.==) (toNullable n1) n1')
150 -- | Left join to the ngram count per document
151 nodeNodeNgramLeftJoin :: Query (NodeRead, NodeNodeNgramReadNull)
152 nodeNodeNgramLeftJoin = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode)
154 eqNode (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' _ _ _) = ((.==) n1 n1')
157 nodeNodeNgramLeftJoin' :: Column (Nullable PGInt4)
158 -> Query (NodeRead, NodeNodeNgramReadNull)
159 nodeNodeNgramLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode nId)
161 eqNode nId' (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' n2 _ _)
162 = (.&&) ((.==) n1 n1')
163 ((.==) nId' (toNullable n2))
166 leftJoin3 :: (Default NullMaker (columnsL1, nullableColumnsR) nullableColumnsR1,
167 Default NullMaker columnsR nullableColumnsR,
168 Default Unpackspec columnsR columnsR,
169 Default Unpackspec nullableColumnsR nullableColumnsR,
170 Default Unpackspec columnsL1 columnsL1,
171 Default Unpackspec columnsL columnsL) =>
172 Query columnsL1 -> Query columnsR -> Query columnsL
173 -> ((columnsL1, columnsR) -> Column PGBool)
174 -> ((columnsL, (columnsL1, nullableColumnsR)) -> Column PGBool)
175 -> Query (columnsL, nullableColumnsR1)
176 leftJoin3 q1 q2 q3 cond12 cond23 = leftJoin q3 (leftJoin q1 q2 cond12) cond23
179 leftJoin3' :: Query (NodeRead, (NodeReadNull, NodeNodeNgramReadNull))
180 leftJoin3' = leftJoin3 queryNodeTable queryNodeNodeNgramTable queryNodeTable cond12 cond23
182 cond12 (Node occId _ _ _ _ _ _, NodeNodeNgram occId' _ _ _)
185 cond23 :: (NodeRead, (NodeRead, NodeNodeNgramReadNull)) -> Column PGBool
186 cond23 (Node docId _ _ _ _ _ _, (Node _ _ _ _ _ _ _, NodeNodeNgram _ docId' _ _))
187 = (.||) ((.==) (toNullable docId) docId') (isNull docId')
190 leftJoin3''' :: Query (NodeRead, (NodeNodeReadNull, NodeReadNull))
191 leftJoin3''' = leftJoin3 queryNodeNodeTable queryNodeTable queryNodeTable cond12 cond23
193 cond12 (NodeNode favId _ _, Node favId' _ _ _ _ _ _)
194 = (.||) ((.==) favId (toNullable favId')) (isNull $ toNullable favId)
196 cond23 :: (NodeRead, (NodeNodeRead, NodeReadNull)) -> Column PGBool
197 cond23 (Node nId _ _ _ _ _ _, (NodeNode _ nId' _, Node _ _ _ _ _ _ _ ))
198 = ((.==) (nId) (nId'))
201 getDocTest' :: Connection -> IO [FacetDoc']
202 getDocTest' conn = runQuery conn selectDocFacet''
204 -- | Building the facet
205 -- selectDocFacet' :: ParentId -> Maybe NodeType -> Query FacetDocRead
206 selectDocFacet'' :: Query FacetDocRead'
207 selectDocFacet'' = proc () -> do
208 (n1,(nn,n2)) <- leftJoin3''' -< ()
209 restrict -< (.&&) (node_parentId n1 .== (toNullable $ pgInt4 347476))
210 (node_typename n1 .== (pgInt4 4))
212 restrict -< (.||) (node_typename n2 .== (toNullable $ pgInt4 15))
213 (isNull $ node_typename n2)
215 restrict -< (.||) (node_parentId n2 .== (toNullable $ pgInt4 347476))
216 (isNull $ node_parentId n2)
218 let isFav = ifThenElse (isNull $ nodeNode_score nn) (pgBool False) (pgBool True)
220 returnA -< FacetDoc' (node_id n1) (node_date n1) (node_hyperdata n1) (isFav) (pgInt4 1)
236 selectDocFacet' :: ParentId -> Maybe NodeType -> Query FacetDocRead
237 selectDocFacet' parentId _ = proc () -> do
238 node <- (proc () -> do
241 -- (Node docId docTypeId _ docParentId _ created docHyperdata, (Node _ favTypeId _ favParentId _ _ _, NodeNode _ docId' _)) <- leftJoin3'' -< ()
242 (Node docId docTypeId _ docParentId _ created docHyperdata, (NodeNode _ docId' _, (Node _ favTypeId _ favParentId _ _ _))) <- leftJoin3''' -< ()
244 restrict -< docTypeId .== (pgInt4 15) .&& docParentId .== (toNullable $ pgInt4 parentId)
246 -- select nn.score from nodes n left join nodes_nodes nn on n.id = nn.node2_id where n.typename =4;
247 -- Selecting the documents and joining Favorite Node
249 restrict -< favParentId .== (toNullable $ pgInt4 parentId) .&& favTypeId .== (toNullable 4)
251 -- let docTypeId'' = maybe 0 nodeTypeId (Just Document)
253 -- Getting favorite data
254 let isFav = ifThenElse (isNull docId') (pgBool False) (pgBool True)
255 -- Ngram count by document
256 -- Counting the ngram
257 -- (Node occId occTypeId _ _ _ _ _, NodeNode _ _ _ count) <- nodeNodeNgramLeftJoin -< ()
258 -- restrict -< occId .== 347540
260 --returnA -< (FacetDoc n_id hyperdata isFav ngramCount)) -< ()
261 returnA -< (FacetDoc docId created docHyperdata isFav)) -< ()