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.Prelude
  49 import Gargantext.Database.Utils (formatPGSQuery)
  50 import Opaleye
  51 import qualified Database.PostgreSQL.Simple as DPS
  52
  53 -- | TODO : remove id
  54 data NodeNgramPoly node_id ngrams_id parent_id ngrams_type list_type weight
  55    = NodeNgram { _nn_node_id    :: node_id
  56                , _nn_ngrams_id  :: ngrams_id
  57                , _nn_parent_id  :: parent_id
  58
  59                , _nn_ngramsType :: ngrams_type
  60                , _nn_listType   :: list_type
  61                , _nn_weight     :: weight
  62                } deriving (Show)
  63
  64 type NodeNgramWrite =
  65      NodeNgramPoly
  66                (Column PGInt4  )
  67                (Column PGInt4  )
  68                (Maybe (Column PGInt4))
  69
  70                (Column PGInt4  )
  71                (Column PGInt4  )
  72                (Column PGFloat8)
  73
  74 type NodeNgramRead =
  75      NodeNgramPoly
  76        (Column PGInt4  )
  77        (Column PGInt4  )
  78        (Column PGInt4  )
  79
  80        (Column PGInt4  )
  81        (Column PGInt4  )
  82        (Column PGFloat8)
  83
  84 type NodeNgramReadNull =
  85      NodeNgramPoly
  86        (Column (Nullable PGInt4  ))
  87        (Column (Nullable PGInt4  ))
  88        (Column (Nullable PGInt4  ))
  89
  90        (Column (Nullable PGInt4  ))
  91        (Column (Nullable PGInt4  ))
  92        (Column (Nullable PGFloat8))
  93
  94 type NodeNgram =
  95      NodeNgramPoly NodeId Int (Maybe NgramsParentId) NgramsTypeId Int Double
  96
  97 newtype NgramsParentId = NgramsParentId Int
  98   deriving (Show, Eq, Num)
  99
 100 pgNgramsParentId :: NgramsParentId -> Column PGInt4
 101 pgNgramsParentId (NgramsParentId n) = pgInt4 n
 102
 103 $(makeAdaptorAndInstance "pNodeNgram" ''NodeNgramPoly)
 104 makeLenses ''NodeNgramPoly
 105
 106 nodeNgramTable :: Table NodeNgramWrite NodeNgramRead
 107 nodeNgramTable  = Table "nodes_ngrams"
 108   ( pNodeNgram NodeNgram
 109     { _nn_node_id    = required "node_id"
 110     , _nn_ngrams_id  = required "ngrams_id"
 111     , _nn_parent_id  = optional "parent_id"
 112     , _nn_ngramsType = required "ngrams_type"
 113     , _nn_listType   = required "list_type"
 114     , _nn_weight     = required "weight"
 115     }
 116   )
 117
 118 queryNodeNgramTable :: Query NodeNgramRead
 119 queryNodeNgramTable = queryTable nodeNgramTable
 120
 121 insertNodeNgrams :: [NodeNgram] -> Cmd err Int
 122 insertNodeNgrams = insertNodeNgramW
 123                  . map (\(NodeNgram n g p ngt lt w) ->
 124                           NodeNgram (pgNodeId n)
 125                                     (pgInt4 g)
 126                                     (pgNgramsParentId <$> p)
 127                                     (pgNgramsTypeId ngt)
 128                                     (pgInt4 lt)
 129                                     (pgDouble w)
 130                         )
 131
 132 insertNodeNgramW :: [NodeNgramWrite] -> Cmd err Int
 133 insertNodeNgramW nns =
 134   mkCmd $ \c -> fromIntegral <$> runInsert_ c insertNothing
 135     where
 136       insertNothing = (Insert { iTable = nodeNgramTable
 137                               , iRows  = nns
 138                               , iReturning = rCount
 139                               , iOnConflict = (Just DoNothing)
 140                               })
 141
 142 type NgramsText = Text
 143
 144 updateNodeNgrams' :: ListId -> [(NgramsTypeId, NgramsText, ListTypeId)] -> Cmd err ()
 145 updateNodeNgrams' _      []    = pure ()
 146 updateNodeNgrams' listId input = void $ execPGSQuery updateQuery (DPS.Only $ Values fields input')
 147   where
 148     fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","text","int4"]
 149     input' = map (\(nt,t,lt) -> (listId, nt, t, lt)) input
 150
 151 updateNodeNgrams'_debug :: ListId -> [(NgramsTypeId, NgramsText, ListTypeId)] -> Cmd err ByteString
 152 updateNodeNgrams'_debug listId input = formatPGSQuery updateQuery (DPS.Only $ Values fields input')
 153   where
 154     fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","text","int4"]
 155     input' = map (\(nt,t,lt) -> (listId, nt, t, lt)) input
 156
 157 updateQuery :: DPS.Query
 158 updateQuery = [sql|
 159 WITH new(node_id,ngrams_type,terms,typeList) as (?)
 160
 161 INSERT into nodes_ngrams (node_id,ngrams_id,ngrams_type,list_type,weight)
 162
 163 SELECT node_id,ngrams.id,ngrams_type,typeList,1 FROM new
 164 JOIN ngrams ON ngrams.terms = new.terms
 165 ON CONFLICT (node_id, ngrams_id, ngrams_type) DO
 166 -- DO NOTHING
 167
 168 UPDATE SET list_type = excluded.list_type
 169 ;
 170                |]
 171
 172 data Action   = Del | Add
 173 type NgramsParent = Text
 174 type NgramsChild  = Text
 175
 176 ngramsGroup :: Action -> ListId -> [(NgramsTypeId, NgramsParent, NgramsChild)] -> Cmd err ()
 177 ngramsGroup _ _ [] = pure ()
 178 ngramsGroup a lid input = void $ trace (show input) $ execPGSQuery (ngramsGroupQuery a) (DPS.Only $ Values fields input')
 179   where
 180     fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","text","int4","text","text"]
 181     input' = map (\(ntpid,p,c) -> (lid, nodeTypeId NodeList, userMaster, ntpid, p,c)) input
 182
 183
 184 ngramsGroupQuery :: Action -> DPS.Query
 185 ngramsGroupQuery a = case a of
 186   Add -> [sql|
 187 WITH input(lid,listTypeId,masterUsername,ntype,parent_terms,child_terms)
 188   AS (?),
 189   -- (VALUES (15::"int4",5::"int4",'gargantua'::"text",4::"int4",'input'::"text",'designer'::"text"))),
 190
 191 list_master AS (
 192    SELECT n.id from nodes n
 193    JOIN auth_user u ON n.user_id = u.id
 194    JOIN input ON n.typename = input.listTypeId
 195    WHERE u.username = input.masterUsername
 196    LIMIT 1
 197 ),
 198
 199 list_user AS(
 200     -- FIRST import parent from master to user list
 201     INSERT INTO nodes_ngrams (node_id,ngrams_id,parent_id,ngrams_type,list_type,weight)
 202     SELECT input.lid,nn.ngrams_id,nn.parent_id,nn.ngrams_type,nn.list_type, nn.weight
 203       FROM INPUT
 204       JOIN ngrams ng       ON ng.terms     = input.parent_terms
 205       JOIN nodes_ngrams nn ON nn.ngrams_id = ng.id
 206       JOIN list_master     ON nn.node_id   = list_master.id
 207     WHERE
 208       nn.ngrams_id = ng.id
 209       ON CONFLICT (node_id,ngrams_id,ngrams_type) DO NOTHING
 210     )
 211
 212 INSERT INTO nodes_ngrams (node_id,ngrams_id,parent_id,ngrams_type,list_type,weight)
 213
 214 SELECT input.lid, nc.id, nnpu.id, input.ntype, nnmaster.list_type, nnmaster.weight
 215 FROM input
 216
 217 JOIN ngrams np ON np.terms = input.parent_terms
 218 JOIN ngrams nc ON nc.terms = input.child_terms
 219
 220 JOIN nodes_ngrams nnpu     ON nnpu.ngrams_id     = np.id
 221 JOIN nodes_ngrams nnmaster ON nnmaster.ngrams_id = nc.id
 222 JOIN list_master           ON nnmaster.node_id   = list_master.id
 223
 224 WHERE
 225     nnpu.node_id     = input.lid
 226 AND nnpu.ngrams_type = input.ntype
 227
 228 AND nnmaster.ngrams_id   = nc.id
 229 AND nnmaster.ngrams_type = ntype
 230
 231 ON CONFLICT (node_id,ngrams_id,ngrams_type) DO
 232 UPDATE SET parent_id = excluded.parent_id
 233
 234
 235   |]
 236   Del -> [sql|
 237 WITH input(lid,listTypeId,masterUsername,ntype,parent_terms,child_terms)
 238   AS (?),
 239   -- (VALUES (15::"int4",5::"int4",'gargantua'::"text",4::"int4",'input'::"text",'designer'::"text"))),
 240
 241 list_master AS (
 242    SELECT n.id from nodes n
 243    JOIN auth_user u ON n.user_id = u.id
 244    JOIN input ON n.typename = input.listTypeId
 245    WHERE u.username = input.masterUsername
 246    LIMIT 1
 247 ),
 248
 249 list_user AS(
 250     -- FIRST import parent from master to user list
 251     INSERT INTO nodes_ngrams (node_id,ngrams_id,parent_id,ngrams_type,list_type,weight)
 252     SELECT input.lid,nn.ngrams_id,nn.parent_id,nn.ngrams_type,nn.list_type, nn.weight
 253       FROM INPUT
 254       JOIN ngrams ng       ON ng.terms     = input.parent_terms
 255       JOIN nodes_ngrams nn ON nn.ngrams_id = ng.id
 256       JOIN list_master     ON nn.node_id   = list_master.id
 257     WHERE
 258       nn.ngrams_id = ng.id
 259       ON CONFLICT (node_id,ngrams_id,ngrams_type) DO NOTHING
 260     )
 261
 262 INSERT INTO nodes_ngrams (node_id,ngrams_id,parent_id,ngrams_type,list_type,weight)
 263
 264 SELECT input.lid, nc.id, NULL, input.ntype, nnmaster.list_type, nnmaster.weight
 265 FROM input
 266
 267 JOIN ngrams np ON np.terms = input.parent_terms
 268 JOIN ngrams nc ON nc.terms = input.child_terms
 269
 270 JOIN nodes_ngrams nnmaster ON nnmaster.ngrams_id = nc.id
 271 JOIN list_master           ON nnmaster.node_id   = list_master.id
 272
 273 WHERE
 274     nnmaster.ngrams_id   = nc.id
 275 AND nnmaster.ngrams_type = ntype
 276
 277 ON CONFLICT (node_id,ngrams_id,ngrams_type) DO
 278 UPDATE SET parent_id = NULL
 279
 280   |]
 281
 282
 283 data NodeNgramsUpdate = NodeNgramsUpdate
 284   { _nnu_user_list_id :: ListId
 285   , _nnu_lists_update :: [(NgramsTypeId, NgramsText, ListTypeId)]
 286   , _nnu_add_children :: [(NgramsTypeId, NgramsParent, NgramsChild)]
 287   , _nnu_rem_children :: [(NgramsTypeId, NgramsParent, NgramsChild)]
 288   }
 289
 290 -- TODO wrap these updates in a transaction.
 291 updateNodeNgrams :: NodeNgramsUpdate -> Cmd err ()
 292 updateNodeNgrams nnu = do
 293   updateNodeNgrams' userListId $ _nnu_lists_update nnu
 294   ngramsGroup Del   userListId $ _nnu_rem_children nnu
 295   ngramsGroup Add   userListId $ _nnu_add_children nnu
 296   -- TODO remove duplicate line (fix SQL query)
 297   ngramsGroup Add   userListId $ _nnu_add_children nnu
 298   where
 299     userListId = _nnu_user_list_id nnu