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.Text (Text)
  34 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
  35 import Control.Monad (void)
  36 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  37 import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
  38 import Database.PostgreSQL.Simple.SqlQQ (sql)
  39 import Gargantext.Core.Types.Main (ListId, ListTypeId)
  40 import Gargantext.Database.Utils (mkCmd, Cmd, execPGSQuery)
  41 import Gargantext.Database.Schema.NodeNgramsNgrams
  42 import Gargantext.Prelude
  43 import Opaleye
  44 import qualified Database.PostgreSQL.Simple as PGS (Only(..))
  45
  46 -- | TODO : remove id
  47 data NodeNgramPoly id node_id ngram_id weight ngrams_type
  48    = NodeNgram { nodeNgram_id      :: id
  49                , nodeNgram_node_id  :: node_id
  50                , nodeNgram_ngrams_id :: ngram_id
  51                , nodeNgram_weight  :: weight
  52                , nodeNgram_type    :: ngrams_type
  53                } deriving (Show)
  54
  55 type NodeNgramWrite =
  56      NodeNgramPoly
  57         (Maybe (Column PGInt4  ))
  58                (Column PGInt4  )
  59                (Column PGInt4  )
  60                (Column PGFloat8)
  61                (Column PGInt4  )
  62
  63 type NodeNgramRead =
  64      NodeNgramPoly
  65        (Column PGInt4  )
  66        (Column PGInt4  )
  67        (Column PGInt4  )
  68        (Column PGFloat8)
  69        (Column PGInt4  )
  70
  71 type NodeNgramReadNull =
  72      NodeNgramPoly
  73        (Column (Nullable PGInt4  ))
  74        (Column (Nullable PGInt4  ))
  75        (Column (Nullable PGInt4  ))
  76        (Column (Nullable PGFloat8))
  77        (Column (Nullable PGInt4  ))
  78
  79 type NodeNgram =
  80      NodeNgramPoly (Maybe Int) Int Int Double Int
  81
  82 $(makeAdaptorAndInstance "pNodeNgram" ''NodeNgramPoly)
  83 $(makeLensesWith abbreviatedFields    ''NodeNgramPoly)
  84
  85
  86 nodeNgramTable :: Table NodeNgramWrite NodeNgramRead
  87 nodeNgramTable  = Table "nodes_ngrams"
  88   ( pNodeNgram NodeNgram
  89     { nodeNgram_id        = optional "id"
  90     , nodeNgram_node_id   = required "node_id"
  91     , nodeNgram_ngrams_id = required "ngram_id"
  92     , nodeNgram_weight    = required "weight"
  93     , nodeNgram_type      = required "ngrams_type"
  94     }
  95   )
  96
  97 queryNodeNgramTable :: Query NodeNgramRead
  98 queryNodeNgramTable = queryTable nodeNgramTable
  99
 100 insertNodeNgrams :: [NodeNgram] -> Cmd err Int
 101 insertNodeNgrams = insertNodeNgramW
 102                  . map (\(NodeNgram _ n g w t) ->
 103                           NodeNgram Nothing (pgInt4 n)   (pgInt4 g)
 104                                             (pgDouble w) (pgInt4 t)
 105                         )
 106
 107 insertNodeNgramW :: [NodeNgramWrite] -> Cmd err Int
 108 insertNodeNgramW nns =
 109   mkCmd $ \c -> fromIntegral <$> runInsert_ c insertNothing
 110     where
 111       insertNothing = (Insert { iTable = nodeNgramTable
 112                               , iRows  = nns
 113                               , iReturning = rCount
 114                               , iOnConflict = (Just DoNothing)
 115                               })
 116
 117 type NgramsText = Text
 118
 119 updateNodeNgrams' :: [(ListId, NgramsText, ListTypeId)] -> Cmd err ()
 120 updateNodeNgrams' [] = pure ()
 121 updateNodeNgrams' input = void $ execPGSQuery updateQuery (PGS.Only $ Values fields input)
 122   where
 123     fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","text","int4"]
 124     updateQuery = [sql| UPDATE nodes_ngrams as old SET
 125                  ngrams_type = new.typeList
 126                  from (?) as new(node_id,terms,typeList)
 127                  JOIN ngrams ON ngrams.terms = new.terms
 128                  WHERE old.node_id = new.node_id
 129                  AND   old.ngram_id = ngrams.id
 130                  RETURNING old.ngram_id;
 131                  |]
 132
 133 data NodeNgramsUpdate = NodeNgramsUpdate
 134   { _nnu_lists_update :: [(ListId, NgramsText, ListTypeId)]
 135   , _nnu_add_children :: [(ListId, NgramsParent, NgramsChild, Maybe Double)]
 136   , _nnu_rem_children :: [(ListId, NgramsParent, NgramsChild, Maybe Double)]
 137   }
 138
 139 -- TODO wrap these updates in a transaction.
 140 updateNodeNgrams :: NodeNgramsUpdate -> Cmd err ()
 141 updateNodeNgrams nnu = do
 142   updateNodeNgrams' $ _nnu_lists_update nnu
 143   ngramsGroup Del   $ _nnu_rem_children nnu
 144   ngramsGroup Add   $ _nnu_add_children nnu