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