src/Gargantext/Database/Query/Table/NodeContext.hs

   1 {-|
   2 Module      : Gargantext.Database.Query.Table.NodeContext
   3 Description :
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 Here is a longer description of this module, containing some
  11 commentary with @some markup@.
  12 -}
  13
  14 {-# OPTIONS_GHC -fno-warn-orphans #-}
  15
  16 {-# LANGUAGE Arrows                 #-}
  17 {-# LANGUAGE FunctionalDependencies #-}
  18 {-# LANGUAGE LambdaCase             #-}
  19 {-# LANGUAGE QuasiQuotes            #-}
  20 {-# LANGUAGE TemplateHaskell        #-}
  21
  22 module Gargantext.Database.Query.Table.NodeContext
  23   ( module Gargantext.Database.Schema.NodeContext
  24   , queryNodeContextTable
  25   , selectDocsDates
  26   , selectDocNodes
  27   , selectDocs
  28   , nodeContextsCategory
  29   , nodeContextsScore
  30   , getNodeContexts
  31   , getNodeContext
  32   , updateNodeContextCategory
  33   , getContextsForNgrams
  34   , ContextForNgrams(..)
  35   , getContextsForNgramsTerms
  36   , getContextNgrams
  37   , getContextNgramsMatchingFTS
  38   , ContextForNgramsTerms(..)
  39   , insertNodeContext
  40   , deleteNodeContext
  41   , selectPublicContexts
  42   , selectCountDocs
  43   )
  44   where
  45
  46 import Control.Arrow (returnA)
  47 import Control.Lens (view, (^.))
  48 import Data.Maybe (catMaybes)
  49 import Data.Time (UTCTime)
  50 import Data.Text (Text, splitOn)
  51 import Database.PostgreSQL.Simple.SqlQQ (sql)
  52 import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
  53 import Opaleye
  54 import qualified Database.PostgreSQL.Simple as PGS (In(..), Query, Only(..))
  55 import qualified Opaleye as O
  56
  57 import Gargantext.Core
  58 import Gargantext.Core.Types
  59 -- import Gargantext.Core.Types.Search (HyperdataRow(..), toHyperdataRow)
  60 import Gargantext.Database.Admin.Types.Hyperdata
  61 import Gargantext.Database.Query.Table.Node.Error (HasNodeError, NodeError(DoesNotExist), nodeError)
  62 import Gargantext.Database.Prelude
  63 import Gargantext.Prelude.Crypto.Hash (Hash)
  64 import Gargantext.Database.Schema.Context
  65 import Gargantext.Database.Schema.Node
  66 import Gargantext.Database.Schema.NodeContext
  67 import Gargantext.Prelude
  68
  69 queryNodeContextTable :: Select NodeContextRead
  70 queryNodeContextTable = selectTable nodeContextTable
  71
  72 -- | not optimized (get all ngrams without filters)
  73 _nodesContexts :: Cmd err [NodeContext]
  74 _nodesContexts = runOpaQuery queryNodeContextTable
  75
  76 ------------------------------------------------------------------------
  77 -- | Basic NodeContext tools
  78 getNodeContexts :: NodeId -> Cmd err [NodeContext]
  79 getNodeContexts n = runOpaQuery (selectNodeContexts $ pgNodeId n)
  80   where
  81     selectNodeContexts :: Field SqlInt4 -> Select NodeContextRead
  82     selectNodeContexts n' = proc () -> do
  83       ns <- queryNodeContextTable -< ()
  84       restrict -< _nc_node_id ns .== n'
  85       returnA -< ns
  86
  87
  88 getNodeContext :: HasNodeError err => ContextId -> NodeId -> Cmd err NodeContext
  89 getNodeContext c n = do
  90   maybeNodeContext <- headMay <$> runOpaQuery (selectNodeContext (pgNodeId c) (pgNodeId n))
  91   case maybeNodeContext of
  92     Nothing -> nodeError (DoesNotExist c)
  93     Just  r -> pure r
  94   where
  95     selectNodeContext :: Field SqlInt4 -> Field SqlInt4 -> Select NodeContextRead
  96     selectNodeContext c' n' = proc () -> do
  97       ns <- queryNodeContextTable -< ()
  98       restrict -< _nc_context_id ns .== c'
  99       restrict -< _nc_node_id ns .== n'
 100       returnA -< ns
 101
 102 updateNodeContextCategory :: ContextId -> NodeId -> Int -> Cmd err Int64
 103 updateNodeContextCategory cId nId cat = do
 104   execPGSQuery upScore (cat, cId, nId)
 105   where
 106     upScore :: PGS.Query
 107     upScore = [sql| UPDATE nodes_contexts
 108                       SET category = ?
 109                       WHERE context_id = ?
 110                       AND node_id = ? |]
 111
 112 data ContextForNgrams =
 113   ContextForNgrams { _cfn_nodeId    :: NodeId
 114                    , _cfn_hash      :: Maybe Hash
 115                    , _cfn_userId    :: UserId
 116                    , _cfn_parentId  :: Maybe ParentId
 117                    , _cfn_c_title   :: ContextTitle
 118                    , _cfn_date      :: UTCTime
 119                    , _cfn_hyperdata :: HyperdataDocument }
 120 getContextsForNgrams :: HasNodeError err
 121                      => NodeId
 122                      -> [Int]
 123                      -> Cmd err [ContextForNgrams]
 124 getContextsForNgrams cId ngramsIds = do
 125   res <- runPGSQuery query (cId, PGS.In ngramsIds)
 126   pure $ (\( _cfn_nodeId
 127            , _cfn_hash
 128            , _cfn_userId
 129            , _cfn_parentId
 130            , _cfn_c_title
 131            , _cfn_date
 132            , _cfn_hyperdata) -> ContextForNgrams { .. }) <$> res
 133   where
 134     query :: PGS.Query
 135     query = [sql| SELECT contexts.id, hash_id, typename, user_id, parent_id, name, date, hyperdata
 136                   FROM contexts
 137                   JOIN context_node_ngrams ON contexts.id = context_node_ngrams.context_id
 138                   JOIN nodes_contexts ON contexts.id = nodes_contexts.context_id
 139                   WHERE nodes_contexts.node_id = ?
 140                    AND context_node_ngrams.ngrams_id IN ? |]
 141
 142 data ContextForNgramsTerms =
 143   ContextForNgramsTerms { _cfnt_nodeId     :: NodeId
 144                         , _cfnt_hash       :: Maybe Hash
 145                         , _cfnt_nodeTypeId :: NodeTypeId
 146                         , _cfnt_userId     :: UserId
 147                         , _cfnt_parentId   :: Maybe ParentId
 148                         , _cfnt_c_title    :: ContextTitle
 149                         , _cfnt_date       :: UTCTime
 150                         , _cfnt_hyperdata  :: HyperdataDocument
 151                         , _cfnt_score      :: Maybe Double
 152                         , _cfnt_category   :: Maybe Int }
 153 getContextsForNgramsTerms :: HasNodeError err
 154                           => NodeId
 155                           -> [Text]
 156                           -> Cmd err [ContextForNgramsTerms]
 157 getContextsForNgramsTerms cId ngramsTerms = do
 158   res <- runPGSQuery query (cId, PGS.In ngramsTerms)
 159   pure $ (\( _cfnt_nodeId
 160            , _cfnt_hash
 161            , _cfnt_nodeTypeId
 162            , _cfnt_userId
 163            , _cfnt_parentId
 164            , _cfnt_c_title
 165            , _cfnt_date
 166            , _cfnt_hyperdata
 167            , _cfnt_score
 168            , _cfnt_category) -> ContextForNgramsTerms { .. }) <$> res
 169   where
 170     query :: PGS.Query
 171     query = [sql| SELECT t.id, t.hash_id, t.typename, t.user_id, t.parent_id, t.name, t.date, t.hyperdata, t.score, t.category
 172                 FROM (
 173                   SELECT DISTINCT ON (contexts.id)
 174                        contexts.id AS id,
 175                        hash_id,
 176                        typename,
 177                        user_id,
 178                        parent_id,
 179                        name,
 180                        date,
 181                        hyperdata,
 182                        nodes_contexts.score AS score,
 183                        nodes_contexts.category AS category,
 184                        context_node_ngrams.doc_count AS doc_count
 185                     FROM contexts
 186                     JOIN context_node_ngrams ON contexts.id = context_node_ngrams.context_id
 187                     JOIN nodes_contexts ON contexts.id = nodes_contexts.context_id
 188                     JOIN ngrams ON context_node_ngrams.ngrams_id = ngrams.id
 189                     WHERE nodes_contexts.node_id = ?
 190                      AND ngrams.terms IN ?) t
 191                    ORDER BY t.doc_count DESC |]
 192
 193
 194
 195 -- | Query the `context_node_ngrams` table and return ngrams for given
 196 -- `context_id` and `list_id`.
 197 -- WARNING: `context_node_ngrams` can be outdated.
 198 getContextNgrams :: HasNodeError err
 199                  => NodeId
 200                  -> NodeId
 201                  -> Cmd err [Text]
 202 getContextNgrams contextId listId = do
 203   res <- runPGSQuery query (contextId, listId)
 204   pure $ (\(PGS.Only term) -> term) <$> res
 205
 206   where
 207     query :: PGS.Query
 208     query = [sql| SELECT ngrams.terms
 209                 FROM context_node_ngrams
 210                 JOIN ngrams ON ngrams.id = ngrams_id
 211                 WHERE context_id = ?
 212                 AND node_id = ? |]
 213
 214
 215 -- | Query the `contexts` table and return ngrams for given context_id
 216 -- and list_id that match the search tsvector.
 217 -- NOTE This is poor man's tokenization that is used as a hint for the
 218 -- frontend highlighter.
 219 getContextNgramsMatchingFTS :: HasNodeError err
 220                             => NodeId
 221                             -> NodeId
 222                             -> Cmd err [Text]
 223 getContextNgramsMatchingFTS contextId listId = do
 224   res <- runPGSQuery query (contextId, listId)
 225   pure $ (\(PGS.Only term) -> term) <$> res
 226
 227   where
 228     query :: PGS.Query
 229     query = [sql| SELECT ngrams.terms
 230                 FROM ngrams
 231                 JOIN node_ngrams ON node_ngrams.ngrams_id = ngrams.id
 232                 CROSS JOIN contexts
 233                 WHERE contexts.id = ?
 234                 AND node_ngrams.node_id = ?
 235                 AND contexts.search @@ phraseto_tsquery(ngrams.terms) |]
 236 ------------------------------------------------------------------------
 237 insertNodeContext :: [NodeContext] -> Cmd err Int
 238 insertNodeContext ns = mkCmd $ \conn -> fromIntegral <$> (runInsert_ conn
 239                           $ Insert nodeContextTable ns' rCount (Just DoNothing))
 240   where
 241     ns' :: [NodeContextWrite]
 242     ns' = map (\(NodeContext i n c x y)
 243                 -> NodeContext (sqlInt4 <$> i)
 244                                (pgNodeId n)
 245                                (pgNodeId c)
 246                                (sqlDouble <$> x)
 247                                (sqlInt4  <$> y)
 248               ) ns
 249
 250
 251 ------------------------------------------------------------------------
 252 type Node_Id    = NodeId
 253 type Context_Id = NodeId
 254
 255 deleteNodeContext :: Node_Id -> Context_Id -> Cmd err Int
 256 deleteNodeContext n c = mkCmd $ \conn ->
 257   fromIntegral <$> runDelete_ conn
 258                               (Delete nodeContextTable
 259                                       (\(NodeContext _ n_id c_id _ _) -> n_id .== pgNodeId n
 260                                                                    .&& c_id .== pgNodeId c
 261                                       )
 262                                       rCount
 263                               )
 264
 265 ------------------------------------------------------------------------
 266 -- | Favorite management
 267 nodeContextsCategory :: [(CorpusId, DocId, Int)] -> Cmd err [Int]
 268 nodeContextsCategory inputData = map (\(PGS.Only a) -> a)
 269                             <$> runPGSQuery catSelect (PGS.Only $ Values fields inputData)
 270   where
 271     fields = map (QualifiedIdentifier Nothing) ["int4","int4","int4"]
 272     catSelect :: PGS.Query
 273     catSelect = [sql| UPDATE nodes_contexts as nn0
 274                       SET category = nn1.category
 275                        FROM (?) as nn1(node_id,context_id,category)
 276                        WHERE nn0.node_id    = nn1.node_id
 277                        AND   nn0.context_id = nn1.context_id
 278                        RETURNING nn1.node_id
 279                   |]
 280
 281 ------------------------------------------------------------------------
 282 -- | Score management
 283 nodeContextsScore :: [(CorpusId, DocId, Int)] -> Cmd err [Int]
 284 nodeContextsScore inputData = map (\(PGS.Only a) -> a)
 285                             <$> runPGSQuery catScore (PGS.Only $ Values fields inputData)
 286   where
 287     fields = map (QualifiedIdentifier Nothing) ["int4","int4","int4"]
 288     catScore :: PGS.Query
 289     catScore = [sql| UPDATE nodes_contexts as nn0
 290                       SET score = nn1.score
 291                        FROM (?) as nn1(node_id, context_id, score)
 292                        WHERE nn0.node_id    = nn1.node_id
 293                        AND   nn0.context_id = nn1.context_id
 294                        RETURNING nn1.context_id
 295                   |]
 296
 297
 298 ------------------------------------------------------------------------
 299 selectCountDocs :: HasDBid NodeType => CorpusId -> Cmd err Int
 300 selectCountDocs cId = runCountOpaQuery (queryCountDocs cId)
 301   where
 302     queryCountDocs cId' = proc () -> do
 303       (c, nc) <- joinInCorpus -< ()
 304       restrict -< restrictMaybe nc $ \nc' -> (nc' ^. nc_node_id)  .== pgNodeId cId' .&&
 305                                              (nc' ^. nc_category) .>= sqlInt4 1
 306       restrict -< (c ^. context_typename) .== sqlInt4 (toDBid NodeDocument)
 307       returnA  -< c
 308
 309
 310 -- | TODO use UTCTime fast
 311 selectDocsDates :: HasDBid NodeType => CorpusId -> Cmd err [Text]
 312 selectDocsDates cId =  map (head' "selectDocsDates" . splitOn "-")
 313                    <$> catMaybes
 314                    <$> map (view hd_publication_date)
 315                    <$> selectDocs cId
 316
 317 selectDocs :: HasDBid NodeType => CorpusId -> Cmd err [HyperdataDocument]
 318 selectDocs cId = runOpaQuery (queryDocs cId)
 319
 320 queryDocs :: HasDBid NodeType => CorpusId -> O.Select (Field SqlJsonb)
 321 queryDocs cId = proc () -> do
 322   (c, nn)  <- joinInCorpus -< ()
 323   restrict -< restrictMaybe nn $ \nn' -> (nn' ^. nc_node_id)  .== pgNodeId cId .&&
 324                                          (nn' ^. nc_category) .>= sqlInt4 1
 325   restrict -< (c ^. context_typename) .== sqlInt4 (toDBid NodeDocument)
 326   returnA  -< view (context_hyperdata) c
 327
 328 selectDocNodes :: HasDBid NodeType => CorpusId -> Cmd err [Context HyperdataDocument]
 329 selectDocNodes cId = runOpaQuery (queryDocNodes cId)
 330
 331 queryDocNodes :: HasDBid NodeType => CorpusId -> O.Select ContextRead
 332 queryDocNodes cId = proc () -> do
 333   (c, nc) <- joinInCorpus -< ()
 334   -- restrict -< restrictMaybe nc $ \nc' -> (nc' ^. nc_node_id)  .== pgNodeId cId .&&
 335   --                                        (nc' ^. nc_category) .>= sqlInt4 1
 336   restrict -< matchMaybe nc $ \case
 337     Nothing  -> toFields True
 338     Just nc' -> (nc' ^. nc_node_id)  .== pgNodeId cId .&&
 339                 (nc' ^. nc_category) .>= sqlInt4 1
 340   restrict -< (c ^. context_typename) .== sqlInt4 (toDBid NodeDocument)
 341   returnA -<  c
 342
 343 joinInCorpus :: O.Select (ContextRead, MaybeFields NodeContextRead)
 344 joinInCorpus = proc () -> do
 345   c <- queryContextTable -< ()
 346   nc <- optionalRestrict queryNodeContextTable -<
 347     (\nc' -> (c ^. context_id) .== (nc' ^. nc_context_id))
 348   returnA -< (c, nc)
 349
 350
 351 joinOn1 :: O.Select (NodeRead, MaybeFields NodeContextRead)
 352 joinOn1 = proc () -> do
 353   n <- queryNodeTable -< ()
 354   nc <- optionalRestrict queryNodeContextTable -<
 355     (\nc' -> (nc' ^. nc_node_id) .== (n ^. node_id))
 356   returnA -< (n, nc)
 357
 358
 359 ------------------------------------------------------------------------
 360 selectPublicContexts :: HasDBid NodeType => (Hyperdata a, DefaultFromField SqlJsonb a)
 361                   => Cmd err [(Node a, Maybe Int)]
 362 selectPublicContexts = runOpaQuery (queryWithType NodeFolderPublic)
 363
 364 queryWithType :: HasDBid NodeType => NodeType -> O.Select (NodeRead, MaybeFields (Field SqlInt4))
 365 queryWithType nt = proc () -> do
 366   (n, nc) <- joinOn1 -< ()
 367   restrict -< (n ^. node_typename) .== sqlInt4 (toDBid nt)
 368   returnA  -<  (n, view nc_context_id <$> nc)