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