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