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 MultiParamTypeClasses  #-}
  23 {-# LANGUAGE NoImplicitPrelude      #-}
  24 {-# LANGUAGE OverloadedStrings      #-}
  25 {-# LANGUAGE QuasiQuotes            #-}
  26 {-# LANGUAGE RankNTypes             #-}
  27 {-# LANGUAGE TemplateHaskell        #-}
  28
  29
  30 -- TODO NodeNgrams
  31 module Gargantext.Database.Schema.NodeNgram where
  32
  33 import Data.ByteString (ByteString)
  34 import Data.Text (Text)
  35 import Control.Lens.TH (makeLenses)
  36 import Control.Monad (void)
  37 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  38 import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
  39 import Database.PostgreSQL.Simple.SqlQQ (sql)
  40 import Gargantext.Core.Types.Main (ListTypeId)
  41 import Gargantext.Database.Utils (mkCmd, Cmd, execPGSQuery)
  42 import Gargantext.Database.Types.Node (NodeId, ListId)
  43 import Gargantext.Database.Schema.Node (pgNodeId)
  44 import Gargantext.Database.Schema.NodeNgramsNgrams (NgramsChild, NgramsParent, ngramsGroup, Action(..))
  45 import Gargantext.Prelude
  46 import Gargantext.Database.Utils (formatPGSQuery)
  47 import Opaleye
  48 import qualified Database.PostgreSQL.Simple as PGS (Only(..), Query)
  49
  50 -- | TODO : remove id
  51 data NodeNgramPoly node_id ngrams_id ngrams_type list_type weight
  52    = NodeNgram { _nn_node_id    :: node_id
  53                , _nn_ngrams_id  :: ngrams_id
  54                , _nn_ngramsType :: ngrams_type
  55                , _nn_listType   :: list_type
  56                , _nn_weight     :: weight
  57                } deriving (Show)
  58
  59 type NodeNgramWrite =
  60      NodeNgramPoly
  61                (Column PGInt4  )
  62                (Column PGInt4  )
  63                (Column PGInt4  )
  64                (Column PGInt4  )
  65                (Column PGFloat8)
  66
  67 type NodeNgramRead =
  68      NodeNgramPoly
  69        (Column PGInt4  )
  70        (Column PGInt4  )
  71        (Column PGInt4  )
  72        (Column PGInt4  )
  73        (Column PGFloat8)
  74
  75 type NodeNgramReadNull =
  76      NodeNgramPoly
  77        (Column (Nullable PGInt4  ))
  78        (Column (Nullable PGInt4  ))
  79        (Column (Nullable PGInt4  ))
  80        (Column (Nullable PGInt4  ))
  81        (Column (Nullable PGFloat8))
  82
  83 type NodeNgram =
  84      NodeNgramPoly NodeId Int Int Int Double
  85
  86 $(makeAdaptorAndInstance "pNodeNgram" ''NodeNgramPoly)
  87 makeLenses ''NodeNgramPoly
  88
  89
  90 nodeNgramTable :: Table NodeNgramWrite NodeNgramRead
  91 nodeNgramTable  = Table "nodes_ngrams"
  92   ( pNodeNgram NodeNgram
  93     { _nn_node_id    = required "node_id"
  94     , _nn_ngrams_id  = required "ngrams_id"
  95     , _nn_ngramsType = required "ngrams_type"
  96     , _nn_listType   = required "list_type"
  97     , _nn_weight     = required "weight"
  98     }
  99   )
 100
 101 queryNodeNgramTable :: Query NodeNgramRead
 102 queryNodeNgramTable = queryTable nodeNgramTable
 103
 104 insertNodeNgrams :: [NodeNgram] -> Cmd err Int
 105 insertNodeNgrams = insertNodeNgramW
 106                  . map (\(NodeNgram n g ngt lt w) ->
 107                           NodeNgram (pgNodeId n)
 108                                     (pgInt4 g)
 109                                     (pgInt4 ngt)
 110                                     (pgInt4 lt)
 111                                     (pgDouble w)
 112                         )
 113
 114 insertNodeNgramW :: [NodeNgramWrite] -> Cmd err Int
 115 insertNodeNgramW nns =
 116   mkCmd $ \c -> fromIntegral <$> runInsert_ c insertNothing
 117     where
 118       insertNothing = (Insert { iTable = nodeNgramTable
 119                               , iRows  = nns
 120                               , iReturning = rCount
 121                               , iOnConflict = (Just DoNothing)
 122                               })
 123
 124 type NgramsText = Text
 125
 126 updateNodeNgrams' :: [(ListId, NgramsText, ListTypeId)] -> Cmd err ()
 127 updateNodeNgrams' [] = pure ()
 128 updateNodeNgrams' input = void $ execPGSQuery updateQuery (PGS.Only $ Values fields input)
 129   where
 130     fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","text","int4"]
 131
 132 updateNodeNgrams'' :: [(ListId, NgramsText, ListTypeId)] -> Cmd err ByteString
 133 updateNodeNgrams'' input = formatPGSQuery updateQuery (PGS.Only $ Values fields input)
 134   where
 135     fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","text","int4"]
 136
 137 updateQuery :: PGS.Query
 138 updateQuery = [sql|
 139 WITH new(node_id,terms,typeList) as (?)
 140
 141 INSERT into nodes_ngrams (node_id,ngrams_id,ngrams_type,list_type,weight)
 142
 143 SELECT node_id,ngrams.id,4,typeList,1 FROM new
 144 JOIN ngrams ON ngrams.terms = new.terms
 145 ON CONFLICT (node_id, ngrams_id, ngrams_type) DO
 146 -- DO NOTHING-
 147
 148 UPDATE SET list_type = excluded.list_type
 149 ;
 150
 151                |]
 152
 153
 154
 155 data NodeNgramsUpdate = NodeNgramsUpdate
 156   { _nnu_lists_update :: [(ListId, NgramsText, ListTypeId)]
 157   , _nnu_add_children :: [(ListId, NgramsParent, NgramsChild, Maybe Double)]
 158   , _nnu_rem_children :: [(ListId, NgramsParent, NgramsChild, Maybe Double)]
 159   }
 160
 161 -- TODO wrap these updates in a transaction.
 162 updateNodeNgrams :: NodeNgramsUpdate -> Cmd err ()
 163 updateNodeNgrams nnu = do
 164   updateNodeNgrams' $ _nnu_lists_update nnu
 165   ngramsGroup Del   $ _nnu_rem_children nnu
 166   ngramsGroup Add   $ _nnu_add_children nnu