src/Gargantext/Database/Schema/NodeNgram.hs

   1 {-|
   2 Module      : Gargantext.Database.Schema.NodeNgrams
   3 Description : NodeNgram for Ngram indexation or Lists
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 NodeNgram: relation between a Node and a Ngrams
  11
  12 if Node is a Document then it is indexing
  13 if Node is a List     then it is listing (either Stop, Candidate or Map)
  14
  15 -}
  16
  17 {-# OPTIONS_GHC -fno-warn-orphans   #-}
  18
  19 {-# LANGUAGE Arrows                     #-}
  20 {-# LANGUAGE FlexibleInstances          #-}
  21 {-# LANGUAGE FunctionalDependencies     #-}
  22 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  23 {-# LANGUAGE MultiParamTypeClasses      #-}
  24 {-# LANGUAGE NoImplicitPrelude          #-}
  25 {-# LANGUAGE OverloadedStrings          #-}
  26 {-# LANGUAGE QuasiQuotes                #-}
  27 {-# LANGUAGE RankNTypes                 #-}
  28 {-# LANGUAGE TemplateHaskell            #-}
  29
  30
  31 -- TODO NodeNgrams
  32 module Gargantext.Database.Schema.NodeNgram where
  33
  34 import Data.ByteString (ByteString)
  35 import Data.Text (Text)
  36 import Debug.Trace (trace)
  37 import Control.Lens.TH (makeLenses)
  38 import Control.Monad (void)
  39 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  40 import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
  41 import Database.PostgreSQL.Simple.SqlQQ (sql)
  42 import Gargantext.Database.Utils (mkCmd, Cmd, execPGSQuery)
  43 import Gargantext.Core.Types.Main (ListTypeId)
  44 import Gargantext.Database.Types.Node (NodeId, ListId, NodeType(..))
  45 import Gargantext.Database.Config (nodeTypeId, userMaster)
  46 import Gargantext.Database.Schema.Node (pgNodeId)
  47 import Gargantext.Database.Schema.Ngrams (NgramsTypeId, pgNgramsTypeId)
  48 import Gargantext.Database.Schema.NodeNgramsNgrams (NgramsChild, NgramsParent, Action(..))
  49 import Gargantext.Prelude
  50 import Gargantext.Database.Utils (formatPGSQuery)
  51 import Opaleye
  52 import qualified Database.PostgreSQL.Simple as PGS (Only(..), Query)
  53
  54 -- | TODO : remove id
  55 data NodeNgramPoly node_id ngrams_id parent_id ngrams_type list_type weight
  56    = NodeNgram { _nn_node_id    :: node_id
  57                , _nn_ngrams_id  :: ngrams_id
  58                , _nn_parent_id  :: parent_id
  59
  60                , _nn_ngramsType :: ngrams_type
  61                , _nn_listType   :: list_type
  62                , _nn_weight     :: weight
  63                } deriving (Show)
  64
  65 type NodeNgramWrite =
  66      NodeNgramPoly
  67                (Column PGInt4  )
  68                (Column PGInt4  )
  69                (Maybe (Column PGInt4))
  70
  71                (Column PGInt4  )
  72                (Column PGInt4  )
  73                (Column PGFloat8)
  74
  75 type NodeNgramRead =
  76      NodeNgramPoly
  77        (Column PGInt4  )
  78        (Column PGInt4  )
  79        (Column PGInt4  )
  80
  81        (Column PGInt4  )
  82        (Column PGInt4  )
  83        (Column PGFloat8)
  84
  85 type NodeNgramReadNull =
  86      NodeNgramPoly
  87        (Column (Nullable PGInt4  ))
  88        (Column (Nullable PGInt4  ))
  89        (Column (Nullable PGInt4  ))
  90
  91        (Column (Nullable PGInt4  ))
  92        (Column (Nullable PGInt4  ))
  93        (Column (Nullable PGFloat8))
  94
  95 type NodeNgram =
  96      NodeNgramPoly NodeId Int (Maybe NgramsParentId) NgramsTypeId Int Double
  97
  98 newtype NgramsParentId = NgramsParentId Int
  99   deriving (Show, Eq, Num)
 100
 101 pgNgramsParentId :: NgramsParentId -> Column PGInt4
 102 pgNgramsParentId (NgramsParentId n) = pgInt4 n
 103
 104 $(makeAdaptorAndInstance "pNodeNgram" ''NodeNgramPoly)
 105 makeLenses ''NodeNgramPoly
 106
 107 nodeNgramTable :: Table NodeNgramWrite NodeNgramRead
 108 nodeNgramTable  = Table "nodes_ngrams"
 109   ( pNodeNgram NodeNgram
 110     { _nn_node_id    = required "node_id"
 111     , _nn_ngrams_id  = required "ngrams_id"
 112     , _nn_parent_id  = optional "parent_id"
 113     , _nn_ngramsType = required "ngrams_type"
 114     , _nn_listType   = required "list_type"
 115     , _nn_weight     = required "weight"
 116     }
 117   )
 118
 119 queryNodeNgramTable :: Query NodeNgramRead
 120 queryNodeNgramTable = queryTable nodeNgramTable
 121
 122 insertNodeNgrams :: [NodeNgram] -> Cmd err Int
 123 insertNodeNgrams = insertNodeNgramW
 124                  . map (\(NodeNgram n g p ngt lt w) ->
 125                           NodeNgram (pgNodeId n)
 126                                     (pgInt4 g)
 127                                     (pgNgramsParentId <$> p)
 128                                     (pgNgramsTypeId ngt)
 129                                     (pgInt4 lt)
 130                                     (pgDouble w)
 131                         )
 132
 133 insertNodeNgramW :: [NodeNgramWrite] -> Cmd err Int
 134 insertNodeNgramW nns =
 135   mkCmd $ \c -> fromIntegral <$> runInsert_ c insertNothing
 136     where
 137       insertNothing = (Insert { iTable = nodeNgramTable
 138                               , iRows  = nns
 139                               , iReturning = rCount
 140                               , iOnConflict = (Just DoNothing)
 141                               })
 142
 143 type NgramsText = Text
 144
 145 updateNodeNgrams' :: [(ListId, NgramsTypeId, NgramsText, ListTypeId)] -> Cmd err ()
 146 updateNodeNgrams' [] = pure ()
 147 updateNodeNgrams' input = void $ execPGSQuery updateQuery (PGS.Only $ Values fields input)
 148   where
 149     fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","text","int4"]
 150
 151 updateNodeNgrams'' :: [(ListId, NgramsTypeId, NgramsText, ListTypeId)] -> Cmd err ByteString
 152 updateNodeNgrams'' input = formatPGSQuery updateQuery (PGS.Only $ Values fields input)
 153   where
 154     fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","text","int4"]
 155
 156 updateQuery :: PGS.Query
 157 updateQuery = [sql|
 158 WITH new(node_id,ngrams_type,terms,typeList) as (?)
 159
 160 INSERT into nodes_ngrams (node_id,ngrams_id,ngrams_type,list_type,weight)
 161
 162 SELECT node_id,ngrams.id,ngrams_type,typeList,1 FROM new
 163 JOIN ngrams ON ngrams.terms = new.terms
 164 ON CONFLICT (node_id, ngrams_id, ngrams_type) DO
 165 -- DO NOTHING
 166
 167 UPDATE SET list_type = excluded.list_type
 168 ;
 169
 170                |]
 171
 172 ngramsGroup' :: Action -> [(ListId, NgramsTypeId, NgramsParent, NgramsChild)] -> Cmd err ()
 173 ngramsGroup' _ [] = pure ()
 174 ngramsGroup' a input = void $ trace (show input) $ execPGSQuery (ngramsGroupQuery a) (PGS.Only $ Values fields input')
 175   where
 176     fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","text","int4","text","text"]
 177     input' = map (\(lid,ntpid,p,c) -> (lid, nodeTypeId NodeList, userMaster, ntpid, p,c)) input
 178
 179
 180 ngramsGroupQuery :: Action -> PGS.Query
 181 ngramsGroupQuery a = case a of
 182   Add -> [sql|
 183 WITH input(lid,listTypeId,masterUsername,ntype,parent_terms,child_terms)
 184   AS (?),
 185   -- (VALUES (15::"int4",5::"int4",'gargantua'::"text",4::"int4",'input'::"text",'designer'::"text"))),
 186
 187 list_master AS (
 188    SELECT n.id from nodes n
 189    JOIN auth_user u ON n.user_id = u.id
 190    JOIN input ON n.typename = input.listTypeId
 191    WHERE u.username = input.masterUsername
 192    LIMIT 1
 193 ),
 194
 195 list_user AS(
 196     -- FIRST import parent from master to user list
 197     INSERT INTO nodes_ngrams (node_id,ngrams_id,parent_id,ngrams_type,list_type,weight)
 198     SELECT input.lid,nn.ngrams_id,nn.parent_id,nn.ngrams_type,nn.list_type, nn.weight
 199       FROM INPUT
 200       JOIN ngrams ng       ON ng.terms     = input.parent_terms
 201       JOIN nodes_ngrams nn ON nn.ngrams_id = ng.id
 202       JOIN list_master     ON nn.node_id   = list_master.id
 203     WHERE
 204       nn.ngrams_id = ng.id
 205       ON CONFLICT (node_id,ngrams_id,ngrams_type) DO NOTHING
 206     )
 207
 208 INSERT INTO nodes_ngrams (node_id,ngrams_id,parent_id,ngrams_type,list_type,weight)
 209
 210 SELECT input.lid, nc.id, nnpu.id, input.ntype, nnmaster.list_type, nnmaster.weight
 211 FROM input
 212
 213 JOIN ngrams np ON np.terms = input.parent_terms
 214 JOIN ngrams nc ON nc.terms = input.child_terms
 215
 216 JOIN nodes_ngrams nnpu     ON nnpu.ngrams_id     = np.id
 217 JOIN nodes_ngrams nnmaster ON nnmaster.ngrams_id = nc.id
 218 JOIN list_master           ON nnmaster.node_id   = list_master.id
 219
 220 WHERE
 221     nnpu.node_id     = input.lid
 222 AND nnpu.ngrams_type = input.ntype
 223
 224 AND nnmaster.ngrams_id   = nc.id
 225 AND nnmaster.ngrams_type = ntype
 226
 227 ON CONFLICT (node_id,ngrams_id,ngrams_type) DO
 228 UPDATE SET parent_id = excluded.parent_id
 229
 230
 231   |]
 232   Del -> [sql|
 233 WITH input(lid,listTypeId,masterUsername,ntype,parent_terms,child_terms)
 234   AS (?),
 235   -- (VALUES (15::"int4",5::"int4",'gargantua'::"text",4::"int4",'input'::"text",'designer'::"text"))),
 236
 237 list_master AS (
 238    SELECT n.id from nodes n
 239    JOIN auth_user u ON n.user_id = u.id
 240    JOIN input ON n.typename = input.listTypeId
 241    WHERE u.username = input.masterUsername
 242    LIMIT 1
 243 ),
 244
 245 list_user AS(
 246     -- FIRST import parent from master to user list
 247     INSERT INTO nodes_ngrams (node_id,ngrams_id,parent_id,ngrams_type,list_type,weight)
 248     SELECT input.lid,nn.ngrams_id,nn.parent_id,nn.ngrams_type,nn.list_type, nn.weight
 249       FROM INPUT
 250       JOIN ngrams ng       ON ng.terms     = input.parent_terms
 251       JOIN nodes_ngrams nn ON nn.ngrams_id = ng.id
 252       JOIN list_master     ON nn.node_id   = list_master.id
 253     WHERE
 254       nn.ngrams_id = ng.id
 255       ON CONFLICT (node_id,ngrams_id,ngrams_type) DO NOTHING
 256     )
 257
 258 INSERT INTO nodes_ngrams (node_id,ngrams_id,parent_id,ngrams_type,list_type,weight)
 259
 260 SELECT input.lid, nc.id, NULL, input.ntype, nnmaster.list_type, nnmaster.weight
 261 FROM input
 262
 263 JOIN ngrams np ON np.terms = input.parent_terms
 264 JOIN ngrams nc ON nc.terms = input.child_terms
 265
 266 JOIN nodes_ngrams nnmaster ON nnmaster.ngrams_id = nc.id
 267 JOIN list_master           ON nnmaster.node_id   = list_master.id
 268
 269 WHERE
 270     nnmaster.ngrams_id   = nc.id
 271 AND nnmaster.ngrams_type = ntype
 272
 273 ON CONFLICT (node_id,ngrams_id,ngrams_type) DO
 274 UPDATE SET parent_id = NULL
 275
 276   |]
 277
 278
 279 data NodeNgramsUpdate = NodeNgramsUpdate
 280   { _nnu_lists_update :: [(ListId, NgramsTypeId, NgramsText, ListTypeId)]
 281   , _nnu_add_children :: [(ListId, NgramsTypeId, NgramsParent, NgramsChild)]
 282   , _nnu_rem_children :: [(ListId, NgramsTypeId, NgramsParent, NgramsChild)]
 283   }
 284
 285 -- TODO wrap these updates in a transaction.
 286 updateNodeNgrams :: NodeNgramsUpdate -> Cmd err ()
 287 updateNodeNgrams nnu = do
 288   updateNodeNgrams' $ _nnu_lists_update nnu
 289   ngramsGroup' Add  $ (trace $ show $ _nnu_add_children nnu) _nnu_add_children nnu
 290   ngramsGroup' Del  $ _nnu_rem_children nnu