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 -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
  60 searchInCorpus cId q o l order = runOpaQuery (filterWith o l order $ queryInCorpus cId q')
  61   where
  62     q' = intercalate " | " $ map stemIt q
  63
  64 queryInCorpus :: CorpusId -> Text -> O.Query FacetDocRead
  65 queryInCorpus cId q = proc () -> do
  66   (n, nn) <- joinInCorpus -< ()
  67   restrict -< ( nn_node1_id nn) .== (toNullable $ pgNodeId cId)
  68   restrict -< ( nn_category nn) .>= (toNullable $ pgInt4     1)
  69   restrict -< (_ns_search n)           @@ (pgTSQuery (unpack q))
  70   restrict -< (_ns_typename n)        .== (pgInt4 $ nodeTypeId NodeDocument)
  71   returnA  -< FacetDoc (_ns_id n) (_ns_date n) (_ns_name n) (_ns_hyperdata n) (pgInt4 1) (pgInt4 1)
  72
  73 joinInCorpus :: O.Query (NodeSearchRead, NodeNodeReadNull)
  74 joinInCorpus = leftJoin queryNodeSearchTable queryNodeNodeTable cond
  75   where
  76     cond :: (NodeSearchRead, NodeNodeRead) -> Column PGBool
  77     cond (n, nn) = nn_node2_id nn .== _ns_id n
  78
  79 ------------------------------------------------------------------------
  80 type AuthorName = Text
  81
  82 -- | TODO Optim: Offset and Limit in the Query
  83 searchInCorpusWithContacts :: CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetPaired Int UTCTime HyperdataDocument Int [Pair Int Text]]
  84 searchInCorpusWithContacts cId q o l order = take (maybe 5 identity l) <$> drop (maybe 0 identity o)
  85   <$> map (\((i,u,h,s), ps) -> FacetPaired i u h s (catMaybes ps))
  86   <$> toList <$> fromListWith (<>)
  87   <$> map (\(FacetPaired i u h s p) -> ((i,u,h,s), [maybePair p]))
  88   <$> searchInCorpusWithContacts' cId q o l order
  89   where
  90     maybePair (Pair Nothing Nothing) = Nothing
  91     maybePair (Pair _ Nothing) = Nothing
  92     maybePair (Pair Nothing _) = Nothing
  93     maybePair (Pair (Just p_id) (Just p_label)) = Just $ Pair p_id p_label
  94
  95 searchInCorpusWithContacts' :: CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [(FacetPaired Int UTCTime HyperdataDocument Int (Pair (Maybe Int) (Maybe Text)))]
  96 searchInCorpusWithContacts' cId q o l order = runOpaQuery $ queryInCorpusWithContacts cId q' o l order
  97   where
  98     q' = intercalate " | " $ map stemIt q
  99
 100
 101
 102 queryInCorpusWithContacts :: CorpusId -> Text -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> O.Query FacetPairedRead
 103 queryInCorpusWithContacts cId q _ _ _ = proc () -> do
 104   (docs, (corpusDoc, (_docNgrams, (ngrams', (_, contacts))))) <- joinInCorpusWithContacts -< ()
 105   restrict -< (_ns_search docs)              @@ (pgTSQuery  $ unpack q  )
 106   restrict -< (_ns_typename docs)           .== (pgInt4 $ nodeTypeId NodeDocument)
 107   restrict -< (nn_node1_id corpusDoc) .== (toNullable $ pgNodeId cId)
 108   -- restrict -< (nng_listType docNgrams)      .== (toNullable $ pgNgramsType Authors)
 109   restrict -< (_node_typename contacts)     .== (toNullable $ pgInt4 $ nodeTypeId NodeContact)
 110   -- let contact_id    = ifThenElse (isNull $ _node_id contacts) (toNullable $ pgInt4 0) (_node_id contacts)
 111   returnA  -< FacetPaired (_ns_id docs) (_ns_date docs) (_ns_hyperdata docs) (pgInt4 0) (Pair (_node_id contacts) (ngrams_terms ngrams'))
 112
 113 joinInCorpusWithContacts :: O.Query (NodeSearchRead, (NodeNodeReadNull, (NodeNodeNgramsReadNull, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull)))))
 114 joinInCorpusWithContacts = leftJoin6 queryNodeTable queryNodeNodeNgramsTable queryNgramsTable queryNodeNodeNgramsTable queryNodeNodeTable queryNodeSearchTable cond12 cond23 cond34 cond45 cond56
 115     where
 116          cond12 :: (NodeNodeNgramsRead, NodeRead) -> Column PGBool
 117          cond12 (ng3, n2) = _node_id n2 .== nnng_node1_id ng3
 118 ---------
 119          cond23 :: (NgramsRead, (NodeNodeNgramsRead, NodeReadNull)) -> Column PGBool
 120          cond23 (ng2, (nnng2, _)) = nnng_ngrams_id nnng2 .== ngrams_id ng2
 121
 122          cond34 :: (NodeNodeNgramsRead, (NgramsRead, (NodeNodeNgramsReadNull, NodeReadNull))) -> Column PGBool
 123          cond34 (nng, (ng, (_,_))) = ngrams_id ng .== nnng_ngrams_id nng
 124
 125          cond45 :: (NodeNodeRead, (NodeNodeNgramsRead, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull)))) -> Column PGBool
 126          cond45 (nn, (nng, (_,(_,_)))) = nnng_node1_id nng .== nn_node2_id nn
 127
 128          cond56 :: (NodeSearchRead, (NodeNodeRead, (NodeNodeNgramsReadNull, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull))))) -> Column PGBool
 129          cond56 (n, (nn, (_,(_,(_,_))))) = _ns_id n .== nn_node2_id nn
 130
 131
 132
 133
 134 newtype TSQuery = UnsafeTSQuery [Text]
 135
 136 -- | TODO [""] -> panic "error"
 137 toTSQuery :: [Text] -> TSQuery
 138 toTSQuery txt = UnsafeTSQuery $ map stemIt txt
 139
 140
 141 instance IsString TSQuery
 142   where
 143     fromString = UnsafeTSQuery . words . cs
 144
 145
 146 instance ToField TSQuery
 147   where
 148     toField (UnsafeTSQuery xs)
 149       = Many  $ intersperse (Plain " && ")
 150               $ map (\q -> Many [ Plain "plainto_tsquery("
 151                                 , Escape (cs q)
 152                                 , Plain ")"
 153                                 ]
 154                     ) xs
 155
 156 data Order    = Asc | Desc
 157
 158 instance ToField Order
 159   where
 160     toField Asc  = Plain "ASC"
 161     toField Desc = Plain "DESC"
 162
 163 -- TODO
 164 -- FIX fav
 165 -- ADD ngrams count
 166 -- TESTS
 167 textSearchQuery :: Query
 168 textSearchQuery = "SELECT n.id, n.hyperdata->'publication_year'     \
 169 \                   , n.hyperdata->'title'                          \
 170 \                   , n.hyperdata->'source'                         \
 171 \                   , n.hyperdata->'authors'                        \
 172 \                   , COALESCE(nn.score,null)                       \
 173 \                      FROM nodes n                                 \
 174 \            LEFT JOIN nodes_nodes nn  ON nn.node2_id = n.id        \
 175 \              WHERE                                                \
 176 \                n.search @@ (?::tsquery)                           \
 177 \                AND (n.parent_id = ? OR nn.node1_id = ?)           \
 178 \                AND n.typename  = ?                                \
 179 \                ORDER BY n.hyperdata -> 'publication_date' ?       \
 180 \            offset ? limit ?;"
 181
 182 -- | Text Search Function for Master Corpus
 183 -- TODO : text search for user corpus
 184 -- Example:
 185 -- textSearchTest :: ParentId -> TSQuery -> Cmd err [(Int, Value, Value, Value, Value, Maybe Int)]
 186 -- textSearchTest pId q = textSearch q pId 5 0 Asc
 187 textSearch :: TSQuery -> ParentId
 188            -> Limit -> Offset -> Order
 189            -> Cmd err [(Int,Value,Value,Value, Value, Maybe Int)]
 190 textSearch q p l o ord = runPGSQuery textSearchQuery (q,p,p,typeId,ord,o,l)
 191   where
 192     typeId = nodeTypeId NodeDocument
 193
 194