]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Database/TextSearch.hs
fix the weightedlogjaccard
[gargantext.git] / src / Gargantext / Database / TextSearch.hs
1 {-|
2 Module : Gargantext.Database.TextSearch
3 Description : Postgres text search experimentation
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 {-# LANGUAGE Arrows #-}
12 {-# LANGUAGE NoImplicitPrelude #-}
13 {-# LANGUAGE OverloadedStrings #-}
14 {-# LANGUAGE RankNTypes #-}
15
16 module Gargantext.Database.TextSearch where
17
18 import Data.Aeson
19 import Data.Map.Strict hiding (map, drop, take)
20 import Data.Maybe
21 import Data.List (intersperse, take, drop)
22 import Data.String (IsString(..))
23 import Data.Text (Text, words, unpack, intercalate)
24 import Data.Time (UTCTime)
25 import Database.PostgreSQL.Simple (Query)
26 import Database.PostgreSQL.Simple.ToField
27 import Gargantext.Database.Config (nodeTypeId)
28 import Gargantext.Database.Types.Node (NodeType(..))
29 import Gargantext.Prelude
30 --import Gargantext.Database.Node.Contact
31 import Gargantext.Database.Facet
32 import Gargantext.Database.Schema.Node
33 import Gargantext.Database.Schema.Ngrams
34 import Gargantext.Database.Schema.NodeNode hiding (joinInCorpus)
35 import Gargantext.Database.Schema.NodeNodeNgrams
36 import Gargantext.Database.Queries.Join (leftJoin6)
37 import Gargantext.Database.Utils (Cmd, runPGSQuery, runOpaQuery)
38 import Gargantext.Text.Terms.Mono.Stem.En (stemIt)
39 import Gargantext.Core.Types
40 import Control.Arrow (returnA)
41 import qualified Opaleye as O hiding (Order)
42 import Opaleye hiding (Query, Order)
43
44
45 ------------------------------------------------------------------------
46 searchInDatabase :: ParentId -> Text -> Cmd err [(NodeId, HyperdataDocument)]
47 searchInDatabase p t = runOpaQuery (queryInDatabase p t)
48
49 -- | Global search query where ParentId is Master Node Corpus Id
50 queryInDatabase :: ParentId -> Text -> O.Query (Column PGInt4, Column PGJsonb)
51 queryInDatabase _ q = proc () -> do
52 row <- queryNodeSearchTable -< ()
53 restrict -< (_ns_search row) @@ (pgTSQuery (unpack q))
54 restrict -< (_ns_typename row) .== (pgInt4 $ nodeTypeId NodeDocument)
55 returnA -< (_ns_id row, _ns_hyperdata row)
56
57 ------------------------------------------------------------------------
58 -- | todo add limit and offset and order
59 searchInCorpus :: CorpusId -> IsTrash -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
60 searchInCorpus cId t q o l order = runOpaQuery (filterWith o l order $ queryInCorpus cId t q')
61 where
62 q' = intercalate " | " $ map stemIt q
63
64 queryInCorpus :: CorpusId -> IsTrash -> Text -> O.Query FacetDocRead
65 queryInCorpus cId t q = proc () -> do
66 (n, nn) <- joinInCorpus -< ()
67 restrict -< ( nn_node1_id nn) .== (toNullable $ pgNodeId cId)
68 restrict -< if t
69 then ( nn_category nn) .== (toNullable $ pgInt4 0)
70 else ( nn_category nn) .>= (toNullable $ pgInt4 1)
71 restrict -< (_ns_search n) @@ (pgTSQuery (unpack q))
72 restrict -< (_ns_typename n) .== (pgInt4 $ nodeTypeId NodeDocument)
73 returnA -< FacetDoc (_ns_id n) (_ns_date n) (_ns_name n) (_ns_hyperdata n) (nn_category nn) (nn_score nn)
74
75 joinInCorpus :: O.Query (NodeSearchRead, NodeNodeReadNull)
76 joinInCorpus = leftJoin queryNodeSearchTable queryNodeNodeTable cond
77 where
78 cond :: (NodeSearchRead, NodeNodeRead) -> Column PGBool
79 cond (n, nn) = nn_node2_id nn .== _ns_id n
80
81 ------------------------------------------------------------------------
82 type AuthorName = Text
83
84 -- | TODO Optim: Offset and Limit in the Query
85 searchInCorpusWithContacts :: CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetPaired Int UTCTime HyperdataDocument Int [Pair Int Text]]
86 searchInCorpusWithContacts cId q o l order = take (maybe 5 identity l) <$> drop (maybe 0 identity o)
87 <$> map (\((i,u,h,s), ps) -> FacetPaired i u h s (catMaybes ps))
88 <$> toList <$> fromListWith (<>)
89 <$> map (\(FacetPaired i u h s p) -> ((i,u,h,s), [maybePair p]))
90 <$> searchInCorpusWithContacts' cId q o l order
91 where
92 maybePair (Pair Nothing Nothing) = Nothing
93 maybePair (Pair _ Nothing) = Nothing
94 maybePair (Pair Nothing _) = Nothing
95 maybePair (Pair (Just p_id) (Just p_label)) = Just $ Pair p_id p_label
96
97 searchInCorpusWithContacts' :: CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [(FacetPaired Int UTCTime HyperdataDocument Int (Pair (Maybe Int) (Maybe Text)))]
98 searchInCorpusWithContacts' cId q o l order = runOpaQuery $ queryInCorpusWithContacts cId q' o l order
99 where
100 q' = intercalate " | " $ map stemIt q
101
102
103
104 queryInCorpusWithContacts :: CorpusId -> Text -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> O.Query FacetPairedRead
105 queryInCorpusWithContacts cId q _ _ _ = proc () -> do
106 (docs, (corpusDoc, (_docNgrams, (ngrams', (_, contacts))))) <- joinInCorpusWithContacts -< ()
107 restrict -< (_ns_search docs) @@ (pgTSQuery $ unpack q )
108 restrict -< (_ns_typename docs) .== (pgInt4 $ nodeTypeId NodeDocument)
109 restrict -< (nn_node1_id corpusDoc) .== (toNullable $ pgNodeId cId)
110 -- restrict -< (nng_listType docNgrams) .== (toNullable $ pgNgramsType Authors)
111 restrict -< (_node_typename contacts) .== (toNullable $ pgInt4 $ nodeTypeId NodeContact)
112 -- let contact_id = ifThenElse (isNull $ _node_id contacts) (toNullable $ pgInt4 0) (_node_id contacts)
113 returnA -< FacetPaired (_ns_id docs) (_ns_date docs) (_ns_hyperdata docs) (pgInt4 0) (Pair (_node_id contacts) (ngrams_terms ngrams'))
114
115 joinInCorpusWithContacts :: O.Query (NodeSearchRead, (NodeNodeReadNull, (NodeNodeNgramsReadNull, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull)))))
116 joinInCorpusWithContacts = leftJoin6 queryNodeTable queryNodeNodeNgramsTable queryNgramsTable queryNodeNodeNgramsTable queryNodeNodeTable queryNodeSearchTable cond12 cond23 cond34 cond45 cond56
117 where
118 cond12 :: (NodeNodeNgramsRead, NodeRead) -> Column PGBool
119 cond12 (ng3, n2) = _node_id n2 .== nnng_node1_id ng3
120 ---------
121 cond23 :: (NgramsRead, (NodeNodeNgramsRead, NodeReadNull)) -> Column PGBool
122 cond23 (ng2, (nnng2, _)) = nnng_ngrams_id nnng2 .== ngrams_id ng2
123
124 cond34 :: (NodeNodeNgramsRead, (NgramsRead, (NodeNodeNgramsReadNull, NodeReadNull))) -> Column PGBool
125 cond34 (nng, (ng, (_,_))) = ngrams_id ng .== nnng_ngrams_id nng
126
127 cond45 :: (NodeNodeRead, (NodeNodeNgramsRead, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull)))) -> Column PGBool
128 cond45 (nn, (nng, (_,(_,_)))) = nnng_node1_id nng .== nn_node2_id nn
129
130 cond56 :: (NodeSearchRead, (NodeNodeRead, (NodeNodeNgramsReadNull, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull))))) -> Column PGBool
131 cond56 (n, (nn, (_,(_,(_,_))))) = _ns_id n .== nn_node2_id nn
132
133
134
135
136 newtype TSQuery = UnsafeTSQuery [Text]
137
138 -- | TODO [""] -> panic "error"
139 toTSQuery :: [Text] -> TSQuery
140 toTSQuery txt = UnsafeTSQuery $ map stemIt txt
141
142
143 instance IsString TSQuery
144 where
145 fromString = UnsafeTSQuery . words . cs
146
147
148 instance ToField TSQuery
149 where
150 toField (UnsafeTSQuery xs)
151 = Many $ intersperse (Plain " && ")
152 $ map (\q -> Many [ Plain "plainto_tsquery("
153 , Escape (cs q)
154 , Plain ")"
155 ]
156 ) xs
157
158 data Order = Asc | Desc
159
160 instance ToField Order
161 where
162 toField Asc = Plain "ASC"
163 toField Desc = Plain "DESC"
164
165 -- TODO
166 -- FIX fav
167 -- ADD ngrams count
168 -- TESTS
169 textSearchQuery :: Query
170 textSearchQuery = "SELECT n.id, n.hyperdata->'publication_year' \
171 \ , n.hyperdata->'title' \
172 \ , n.hyperdata->'source' \
173 \ , n.hyperdata->'authors' \
174 \ , COALESCE(nn.score,null) \
175 \ FROM nodes n \
176 \ LEFT JOIN nodes_nodes nn ON nn.node2_id = n.id \
177 \ WHERE \
178 \ n.search @@ (?::tsquery) \
179 \ AND (n.parent_id = ? OR nn.node1_id = ?) \
180 \ AND n.typename = ? \
181 \ ORDER BY n.hyperdata -> 'publication_date' ? \
182 \ offset ? limit ?;"
183
184 -- | Text Search Function for Master Corpus
185 -- TODO : text search for user corpus
186 -- Example:
187 -- textSearchTest :: ParentId -> TSQuery -> Cmd err [(Int, Value, Value, Value, Value, Maybe Int)]
188 -- textSearchTest pId q = textSearch q pId 5 0 Asc
189 textSearch :: TSQuery -> ParentId
190 -> Limit -> Offset -> Order
191 -> Cmd err [(Int,Value,Value,Value, Value, Maybe Int)]
192 textSearch q p l o ord = runPGSQuery textSearchQuery (q,p,p,typeId,ord,o,l)
193 where
194 typeId = nodeTypeId NodeDocument
195
196