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 -}
  12
  13 {-# LANGUAGE Arrows            #-}
  14 {-# LANGUAGE NoImplicitPrelude #-}
  15 {-# LANGUAGE OverloadedStrings #-}
  16
  17 module Gargantext.Database.TextSearch where
  18
  19
  20 import Data.Aeson
  21 import Data.List (intersperse)
  22 import Data.String (IsString(..))
  23 import Data.Text (Text, words)
  24
  25 import Database.PostgreSQL.Simple
  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
  31 import Gargantext.Database.Queries
  32 import Gargantext.Core.Types
  33 import Control.Arrow (returnA)
  34 import qualified Opaleye as O hiding (Order)
  35 import Opaleye hiding (Query, Order)
  36
  37 newtype TSQuery = UnsafeTSQuery [Text]
  38
  39
  40
  41 searchQuery :: O.Query NodeRead
  42 searchQuery = proc () -> do
  43     row <- queryNodeTable -< ()
  44     restrict -< (_node_search row) @@ (pgTSQuery "test")
  45     returnA -< row
  46
  47
  48
  49 -- | TODO [""] -> panic "error"
  50 toTSQuery :: [Text] -> TSQuery
  51 toTSQuery txt = UnsafeTSQuery txt
  52
  53
  54 instance IsString TSQuery
  55   where
  56     fromString = UnsafeTSQuery . words . cs
  57
  58
  59 instance ToField TSQuery
  60   where
  61     toField (UnsafeTSQuery xs)
  62       = Many  $ intersperse (Plain " && ")
  63               $ map (\q -> Many [ Plain "plainto_tsquery("
  64                                 , Escape (cs q)
  65                                 , Plain ")"
  66                                 ]
  67                     ) xs
  68
  69 data Order    = Asc | Desc
  70
  71 instance ToField Order
  72   where
  73     toField Asc  = Plain "ASC"
  74     toField Desc = Plain "DESC"
  75
  76 -- TODO
  77 -- FIX fav
  78 -- ADD ngrams count
  79 -- TESTS
  80 textSearchQuery :: Query
  81 textSearchQuery = "SELECT n.id, n.hyperdata->'publication_year'     \
  82 \                   , n.hyperdata->'title'                          \
  83 \                   , n.hyperdata->'source'                         \
  84 \                   , n.hyperdata->'authors'                        \
  85 \                   , COALESCE(nn.score,null)                       \
  86 \                      FROM nodes n                                 \
  87 \            LEFT JOIN nodes_nodes nn  ON nn.node2_id = n.id        \
  88 \              WHERE                                                \
  89 \                n.search @@ (?::tsquery)                           \
  90 \                AND (n.parent_id = ? OR nn.node1_id = ?)           \
  91 \                AND n.typename  = ?                                \
  92 \                ORDER BY n.hyperdata -> 'publication_date' ?       \
  93 \            offset ? limit ?;"
  94
  95 -- | Text Search Function for Master Corpus
  96 -- TODO : text search for user corpus
  97 -- Example:
  98 -- textSearchTest :: ParentId -> TSQuery -> Cmd [(Int, Value, Value, Value, Value, Maybe Int)]
  99 -- textSearchTest pId q = mkCmd $ \c -> textSearch c q pId 5 0 Asc
 100 textSearch :: Connection
 101            -> TSQuery -> ParentId
 102            -> Limit -> Offset -> Order
 103            -> IO [(Int,Value,Value,Value, Value, Maybe Int)]
 104 textSearch conn q p l o ord = query conn textSearchQuery (q,p,p,typeId,ord,o,l)
 105   where
 106     typeId = nodeTypeId NodeDocument
 107
 108