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