src/Gargantext/Database/Action/Search.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
  13 module Gargantext.Database.Action.Search where
  14
  15 import Control.Arrow (returnA)
  16 import Control.Lens ((^.))
  17 import Data.Maybe
  18 import Data.Text (Text, unpack, intercalate)
  19 import Data.Time (UTCTime)
  20 import Gargantext.Core
  21 import Gargantext.Core.Types
  22 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..), HyperdataContact(..))
  23 import Gargantext.Database.Prelude (Cmd, runOpaQuery, runCountOpaQuery)
  24 import Gargantext.Database.Query.Facet
  25 import Gargantext.Database.Query.Filter
  26 import Gargantext.Database.Query.Join (leftJoin5)
  27 import Gargantext.Database.Query.Table.Node
  28 import Gargantext.Database.Query.Table.Context
  29 import Gargantext.Database.Query.Table.NodeContext
  30 import Gargantext.Database.Query.Table.NodeContext_NodeContext
  31 import Gargantext.Database.Schema.Node
  32 import Gargantext.Database.Schema.Context
  33 import Gargantext.Prelude
  34 import Gargantext.Core.Text.Terms.Mono.Stem.En (stemIt)
  35 import Opaleye hiding (Order)
  36 import Data.Profunctor.Product (p4)
  37 import qualified Opaleye as O hiding (Order)
  38
  39 ------------------------------------------------------------------------
  40 searchDocInDatabase :: HasDBid NodeType
  41                     => ParentId
  42                     -> Text
  43                     -> Cmd err [(NodeId, HyperdataDocument)]
  44 searchDocInDatabase p t = runOpaQuery (queryDocInDatabase p t)
  45   where
  46     -- | Global search query where ParentId is Master Node Corpus Id
  47     queryDocInDatabase :: ParentId -> Text -> O.Select (Column SqlInt4, Column SqlJsonb)
  48     queryDocInDatabase _p q = proc () -> do
  49         row <- queryNodeSearchTable -< ()
  50         restrict -< (_ns_search row)    @@ (sqlTSQuery (unpack q))
  51         restrict -< (_ns_typename row) .== (sqlInt4 $ toDBid NodeDocument)
  52         returnA  -< (_ns_id row, _ns_hyperdata row)
  53
  54 ------------------------------------------------------------------------
  55 -- | todo add limit and offset and order
  56 searchInCorpus :: HasDBid NodeType
  57                => CorpusId
  58                -> IsTrash
  59                -> [Text]
  60                -> Maybe Offset
  61                -> Maybe Limit
  62                -> Maybe OrderBy
  63                -> Cmd err [FacetDoc]
  64 searchInCorpus cId t q o l order = runOpaQuery
  65                                  $ filterWith o l order
  66                                  $ queryInCorpus cId t
  67                                  $ intercalate " | "
  68                                  $ map stemIt q
  69
  70 searchCountInCorpus :: HasDBid NodeType
  71                     => CorpusId
  72                     -> IsTrash
  73                     -> [Text]
  74                     -> Cmd err Int
  75 searchCountInCorpus cId t q = runCountOpaQuery
  76                             $ queryInCorpus cId t
  77                             $ intercalate " | "
  78                             $ map stemIt q
  79
  80 queryInCorpus :: HasDBid NodeType
  81               => CorpusId
  82               -> IsTrash
  83               -> Text
  84               -> O.Select FacetDocRead
  85 queryInCorpus cId t q = proc () -> do
  86   (c, nc) <- joinInCorpus -< ()
  87   restrict -< (nc^.nc_node_id) .== (toNullable $ pgNodeId cId)
  88   restrict -< if t
  89                  then (nc^.nc_category) .== (toNullable $ sqlInt4 0)
  90                  else (nc^.nc_category) .>= (toNullable $ sqlInt4 1)
  91   restrict -< (c ^. cs_search)           @@ (sqlTSQuery (unpack q))
  92   restrict -< (c ^. cs_typename )       .== (sqlInt4 $ toDBid NodeDocument)
  93   returnA  -< FacetDoc { facetDoc_id         = c^.cs_id
  94                        , facetDoc_created    = c^.cs_date
  95                        , facetDoc_title      = c^.cs_name
  96                        , facetDoc_hyperdata  = c^.cs_hyperdata
  97                        , facetDoc_category   = nc^.nc_category
  98                        , facetDoc_ngramCount = nc^.nc_score
  99                        , facetDoc_score      = nc^.nc_score
 100                        }
 101
 102 joinInCorpus :: O.Select (ContextSearchRead, NodeContextReadNull)
 103 joinInCorpus = leftJoin queryContextSearchTable queryNodeContextTable cond
 104   where
 105     cond :: (ContextSearchRead, NodeContextRead) -> Column SqlBool
 106     cond (c, nc) = nc^.nc_context_id .== _cs_id c
 107
 108 ------------------------------------------------------------------------
 109 searchInCorpusWithContacts
 110   :: HasDBid NodeType
 111   => CorpusId
 112   -> AnnuaireId
 113   -> [Text]
 114   -> Maybe Offset
 115   -> Maybe Limit
 116   -> Maybe OrderBy
 117   -> Cmd err [FacetPaired Int UTCTime HyperdataContact Int]
 118 searchInCorpusWithContacts cId aId q o l _order =
 119   runOpaQuery $ limit'   l
 120               $ offset'  o
 121               $ orderBy (desc _fp_score)
 122               $ selectGroup cId aId
 123               $ intercalate " | "
 124               $ map stemIt q
 125
 126 selectGroup :: HasDBid NodeType
 127             => CorpusId
 128             -> AnnuaireId
 129             -> Text
 130             -> Select FacetPairedReadNull
 131 selectGroup cId aId q = proc () -> do
 132   (a, b, c, d) <- aggregate (p4 (groupBy, groupBy, groupBy, O.sum))
 133                             (selectContactViaDoc cId aId q) -< ()
 134   returnA -< FacetPaired a b c d
 135
 136
 137 selectContactViaDoc
 138   :: HasDBid NodeType
 139   => CorpusId
 140   -> AnnuaireId
 141   -> Text
 142   -> SelectArr ()
 143                ( Column (Nullable SqlInt4)
 144                , Column (Nullable SqlTimestamptz)
 145                , Column (Nullable SqlJsonb)
 146                , Column (Nullable SqlInt4)
 147                )
 148 selectContactViaDoc cId aId query = proc () -> do
 149   (doc, (corpus, (_nodeContext_nodeContext, (annuaire, contact)))) <- queryContactViaDoc -< ()
 150   restrict -< (doc^.cs_search)             @@ (sqlTSQuery $ unpack query                )
 151   restrict -< (doc^.cs_typename)          .== (sqlInt4    $ toDBid NodeDocument         )
 152   restrict -< (corpus^.nc_node_id)        .== (toNullable $ pgNodeId cId                )
 153   restrict -< (annuaire^.nc_node_id)      .== (toNullable $ pgNodeId aId                )
 154   restrict -< (contact^.context_typename) .== (toNullable $ sqlInt4 $ toDBid NodeContact)
 155   returnA  -< ( contact^.context_id
 156               , contact^.context_date
 157               , contact^.context_hyperdata
 158               , toNullable $ sqlInt4 1
 159               )
 160
 161 queryContactViaDoc :: O.Select ( ContextSearchRead
 162                                , ( NodeContextReadNull
 163                                  , ( NodeContext_NodeContextReadNull
 164                                    , ( NodeContextReadNull
 165                                      , ContextReadNull
 166                                      )
 167                                    )
 168                                  )
 169                                )
 170 queryContactViaDoc =
 171   leftJoin5
 172   queryContextTable
 173   queryNodeContextTable
 174   queryNodeContext_NodeContextTable
 175   queryNodeContextTable
 176   queryContextSearchTable
 177   cond12
 178   cond23
 179   cond34
 180   cond45
 181     where
 182       cond12 :: (NodeContextRead, ContextRead) -> Column SqlBool
 183       cond12 (annuaire, contact) = contact^.context_id .== annuaire^.nc_context_id
 184
 185       cond23 :: ( NodeContext_NodeContextRead
 186                 , ( NodeContextRead
 187                   , ContextReadNull
 188                   )
 189                 ) -> Column SqlBool
 190       cond23 (nodeContext_nodeContext, (annuaire, _)) = nodeContext_nodeContext^.ncnc_nodecontext2 .== annuaire^.nc_id
 191
 192       cond34 :: ( NodeContextRead
 193                 , ( NodeContext_NodeContextRead
 194                   , ( NodeContextReadNull
 195                     , ContextReadNull
 196                     )
 197                   )
 198                 ) -> Column SqlBool
 199       cond34 (corpus, (nodeContext_nodeContext, (_,_))) =  nodeContext_nodeContext^.ncnc_nodecontext1 .== corpus^.nc_id
 200
 201
 202       cond45 :: ( ContextSearchRead
 203                 , ( NodeContextRead
 204                   , ( NodeContext_NodeContextReadNull
 205                     , ( NodeContextReadNull
 206                       , ContextReadNull
 207                       )
 208                     )
 209                   )
 210                 ) -> Column SqlBool
 211       cond45 (doc, (corpus, (_,(_,_)))) = doc^.cs_id .== corpus^.nc_context_id
 212