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 FlexibleContexts #-}
17 {-# LANGUAGE FlexibleInstances #-}
18 {-# LANGUAGE FunctionalDependencies #-}
19 {-# LANGUAGE MultiParamTypeClasses #-}
20 {-# LANGUAGE QuasiQuotes #-}
21 {-# LANGUAGE NoImplicitPrelude #-}
22 {-# LANGUAGE NoMonomorphismRestriction #-}
23 {-# LANGUAGE OverloadedStrings #-}
24 {-# LANGUAGE TemplateHaskell #-}
25 ------------------------------------------------------------------------
26 module Gargantext.Database.Facet
28 ------------------------------------------------------------------------
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)
38 import Data.Text (Text)
39 import Data.Time (UTCTime)
40 import Data.Time.Segment (jour)
41 import Database.PostgreSQL.Simple (Connection)
42 import GHC.Generics (Generic)
43 import Gargantext.Core.Types
44 import Gargantext.Core.Utils.Prefix (unPrefix)
45 import Gargantext.Database.Config (nodeTypeId)
46 import Gargantext.Database.Schema.Ngrams
47 import Gargantext.Database.Schema.Node
48 import Gargantext.Database.Schema.NodeNgram
49 import Gargantext.Database.Schema.NodeNode
50 import Gargantext.Database.Utils
51 import Gargantext.Database.Queries.Join
52 import Gargantext.Database.Queries.Filter
54 import Prelude hiding (null, id, map, sum, not, read)
56 import Test.QuickCheck (elements)
57 import Test.QuickCheck.Arbitrary
58 import qualified Opaleye.Internal.Unpackspec()
60 ------------------------------------------------------------------------
63 -- data Facet = FacetDoc | FacetSources | FacetAuthors | FacetTerms
64 -- deriving (Show, Generic)
65 --instance FromJSON Facet
66 --instance ToJSON Facet
71 type FacetDoc = Facet NodeId UTCTime Title HyperdataDocument Favorite Int
72 type FacetSources = FacetDoc
73 type FacetAuthors = FacetDoc
74 type FacetTerms = FacetDoc
78 data Facet id created title hyperdata favorite ngramCount =
79 FacetDoc { facetDoc_id :: id
80 , facetDoc_created :: created
81 , facetDoc_title :: title
82 , facetDoc_hyperdata :: hyperdata
83 , facetDoc_favorite :: favorite
84 , facetDoc_ngramCount :: ngramCount
85 } deriving (Show, Generic)
89 $(deriveJSON (unPrefix "facetDoc_") ''Facet)
91 -- | Documentation instance
92 instance ToSchema FacetDoc
94 -- | Mock and Quickcheck instances
96 instance Arbitrary FacetDoc where
97 arbitrary = elements [ FacetDoc id' (jour year 01 01) t hp fav ngramCount
99 , year <- [1990..2000]
100 , t <- ["title", "another title"]
101 , hp <- hyperdataDocuments
102 , fav <- [True, False]
103 , ngramCount <- [3..100]
106 -- Facets / Views for the Front End
107 -- | Database instances
108 $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
109 $(makeLensesWith abbreviatedFields ''Facet)
111 type FacetDocRead = Facet (Column PGInt4 )
112 (Column PGTimestamptz)
118 -----------------------------------------------------------------------
120 data FacetChart = FacetChart { facetChart_time :: UTCTime'
121 , facetChart_count :: Double
123 deriving (Show, Generic)
124 $(deriveJSON (unPrefix "facetChart_") ''FacetChart)
125 instance ToSchema FacetChart
127 instance Arbitrary FacetChart where
128 arbitrary = FacetChart <$> arbitrary <*> arbitrary
130 -----------------------------------------------------------------------
132 data OrderBy = DateAsc | DateDesc
133 | TitleAsc | TitleDesc
135 deriving (Generic, Enum, Bounded, Read, Show)
138 instance FromHttpApiData OrderBy
140 parseUrlPiece "DateAsc" = pure DateAsc
141 parseUrlPiece "DateDesc" = pure DateDesc
142 parseUrlPiece "TitleAsc" = pure TitleAsc
143 parseUrlPiece "TitleDesc" = pure TitleDesc
144 parseUrlPiece "FavAsc" = pure FavAsc
145 parseUrlPiece "FavDesc" = pure FavDesc
146 parseUrlPiece _ = Left "Unexpected value of OrderBy"
148 instance ToParamSchema OrderBy
149 instance FromJSON OrderBy
150 instance ToJSON OrderBy
151 instance ToSchema OrderBy
152 instance Arbitrary OrderBy
154 arbitrary = elements [minBound..maxBound]
157 runViewAuthorsDoc :: Connection -> ContactId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [FacetDoc]
158 runViewAuthorsDoc c cId t o l order = runQuery c (filterDocuments o l order $ viewAuthorsDoc cId t ntId)
163 viewAuthorsDoc :: ContactId -> Trash -> NodeType -> Query FacetDocRead
164 viewAuthorsDoc cId _ nt = proc () -> do
165 (doc,(_,(_,(_,contact)))) <- queryAuthorsDoc -< ()
167 {-nn <- queryNodeNodeTable -< ()
168 restrict -< nodeNode_node1_id nn .== _node_id doc
169 -- restrict -< nodeNode_delete nn .== (pgBool t)
172 restrict -< _node_id contact .== (toNullable $ pgInt4 cId)
173 restrict -< _node_typename doc .== (pgInt4 $ nodeTypeId nt)
175 returnA -< FacetDoc (_node_id doc) (_node_date doc) (_node_name doc) (_node_hyperdata doc) (pgBool True) (pgInt4 1)
177 queryAuthorsDoc :: Query (NodeRead, (NodeNgramReadNull, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull))))
178 queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable queryNodeNgramTable queryNodeTable cond12 cond23 cond34 cond45
180 cond12 :: (NodeNgramRead, NodeRead) -> Column PGBool
181 cond12 (nodeNgram, doc) = _node_id doc
182 .== nodeNgram_node_id nodeNgram
184 cond23 :: (NgramsRead, (NodeNgramRead, NodeReadNull)) -> Column PGBool
185 cond23 (ngrams, (nodeNgram, _)) = ngrams_id ngrams
186 .== nodeNgram_ngrams_id nodeNgram
188 cond34 :: (NodeNgramRead, (NgramsRead, (NodeNgramReadNull, NodeReadNull))) -> Column PGBool
189 cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams_id ngrams .== nodeNgram_ngrams_id nodeNgram2
191 cond45 :: (NodeRead, (NodeNgramRead, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull)))) -> Column PGBool
192 cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id contact .== nodeNgram_node_id nodeNgram2
195 ------------------------------------------------------------------------
197 runViewDocuments :: CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd [FacetDoc]
198 runViewDocuments cId t o l order = mkCmd $ \c -> runViewDocuments' c cId t o l order
200 -- | TODO use only Cmd with Reader and delete function below
201 runViewDocuments' :: Connection -> CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [FacetDoc]
202 runViewDocuments' c cId t o l order = runQuery c ( filterDocuments o l order
203 $ viewDocuments cId t ntId)
205 ntId = nodeTypeId NodeDocument
207 viewDocuments :: CorpusId -> Trash -> NodeTypeId -> Query FacetDocRead
208 viewDocuments cId t ntId = proc () -> do
209 n <- queryNodeTable -< ()
210 nn <- queryNodeNodeTable -< ()
211 restrict -< _node_id n .== nodeNode_node2_id nn
212 restrict -< nodeNode_node1_id nn .== (pgInt4 cId)
213 restrict -< _node_typename n .== (pgInt4 ntId)
214 restrict -< nodeNode_delete nn .== (pgBool t)
215 returnA -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (nodeNode_favorite nn) (pgInt4 1)
218 ------------------------------------------------------------------------
220 filterDocuments :: (PGOrd date, PGOrd title, PGOrd favorite) =>
221 Maybe Gargantext.Core.Types.Offset
222 -> Maybe Gargantext.Core.Types.Limit
224 -> Select (Facet id (Column date) (Column title) hyperdata (Column favorite) ngramCount)
225 -> Query (Facet id (Column date) (Column title) hyperdata (Column favorite) ngramCount)
226 filterDocuments o l order q = limit' l $ offset' o $ orderBy ordering q
228 ordering = case order of
229 (Just DateAsc) -> asc facetDoc_created
231 (Just TitleAsc) -> asc facetDoc_title
232 (Just TitleDesc) -> desc facetDoc_title
234 (Just FavAsc) -> asc facetDoc_favorite
235 (Just FavDesc) -> desc facetDoc_favorite
236 _ -> desc facetDoc_created