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.Ngrams (NgramsTypeId, pgNgramsTypeId)
  45 import Gargantext.Database.Schema.NodeNgramsNgrams (NgramsChild, NgramsParent, ngramsGroup, Action(..))
  46 import Gargantext.Prelude
  47 import Gargantext.Database.Utils (formatPGSQuery)
  48 import Opaleye
  49 import qualified Database.PostgreSQL.Simple as PGS (Only(..), Query)
  50
  51 -- | TODO : remove id
  52 data NodeNgramPoly node_id ngrams_id ngrams_type list_type weight
  53    = NodeNgram { _nn_node_id    :: node_id
  54                , _nn_ngrams_id  :: ngrams_id
  55                , _nn_ngramsType :: ngrams_type
  56                , _nn_listType   :: list_type
  57                , _nn_weight     :: weight
  58                } deriving (Show)
  59
  60 type NodeNgramWrite =
  61      NodeNgramPoly
  62                (Column PGInt4  )
  63                (Column PGInt4  )
  64                (Column PGInt4  )
  65                (Column PGInt4  )
  66                (Column PGFloat8)
  67
  68 type NodeNgramRead =
  69      NodeNgramPoly
  70        (Column PGInt4  )
  71        (Column PGInt4  )
  72        (Column PGInt4  )
  73        (Column PGInt4  )
  74        (Column PGFloat8)
  75
  76 type NodeNgramReadNull =
  77      NodeNgramPoly
  78        (Column (Nullable PGInt4  ))
  79        (Column (Nullable PGInt4  ))
  80        (Column (Nullable PGInt4  ))
  81        (Column (Nullable PGInt4  ))
  82        (Column (Nullable PGFloat8))
  83
  84 type NodeNgram =
  85      NodeNgramPoly NodeId Int NgramsTypeId Int Double
  86
  87 $(makeAdaptorAndInstance "pNodeNgram" ''NodeNgramPoly)
  88 makeLenses ''NodeNgramPoly
  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                                     (pgNgramsTypeId 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, NgramsTypeId, 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","int4","text","int4"]
 131
 132 updateNodeNgrams'' :: [(ListId, NgramsTypeId, 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","int4","text","int4"]
 136
 137 updateQuery :: PGS.Query
 138 updateQuery = [sql|
 139 WITH new(node_id,ngrams_type,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,ngrams_type,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, NgramsTypeId, 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