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