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