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 Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  36 import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
  37 import Database.PostgreSQL.Simple.SqlQQ (sql)
  38 import Gargantext.Core.Types.Main (ListId, ListTypeId)
  39 import Gargantext.Database.Utils (mkCmd, Cmd, runPGSQuery)
  40 import Gargantext.Database.Schema.NodeNgramsNgrams
  41 import Gargantext.Prelude
  42 import Opaleye
  43 import qualified Database.PostgreSQL.Simple as PGS (Only(..))
  44
  45 -- | TODO : remove id
  46 data NodeNgramPoly id node_id ngram_id weight ngrams_type
  47    = NodeNgram { nodeNgram_id      :: id
  48                , nodeNgram_node_id  :: node_id
  49                , nodeNgram_ngrams_id :: ngram_id
  50                , nodeNgram_weight  :: weight
  51                , nodeNgram_type    :: ngrams_type
  52                } deriving (Show)
  53
  54 type NodeNgramWrite =
  55      NodeNgramPoly
  56         (Maybe (Column PGInt4  ))
  57                (Column PGInt4  )
  58                (Column PGInt4  )
  59                (Column PGFloat8)
  60                (Column PGInt4  )
  61
  62 type NodeNgramRead =
  63      NodeNgramPoly
  64        (Column PGInt4  )
  65        (Column PGInt4  )
  66        (Column PGInt4  )
  67        (Column PGFloat8)
  68        (Column PGInt4  )
  69
  70 type NodeNgramReadNull =
  71      NodeNgramPoly
  72        (Column (Nullable PGInt4  ))
  73        (Column (Nullable PGInt4  ))
  74        (Column (Nullable PGInt4  ))
  75        (Column (Nullable PGFloat8))
  76        (Column (Nullable PGInt4  ))
  77
  78 type NodeNgram =
  79      NodeNgramPoly (Maybe Int) Int Int Double Int
  80
  81 $(makeAdaptorAndInstance "pNodeNgram" ''NodeNgramPoly)
  82 $(makeLensesWith abbreviatedFields    ''NodeNgramPoly)
  83
  84
  85 nodeNgramTable :: Table NodeNgramWrite NodeNgramRead
  86 nodeNgramTable  = Table "nodes_ngrams"
  87   ( pNodeNgram NodeNgram
  88     { nodeNgram_id        = optional "id"
  89     , nodeNgram_node_id   = required "node_id"
  90     , nodeNgram_ngrams_id = required "ngram_id"
  91     , nodeNgram_weight    = required "weight"
  92     , nodeNgram_type      = required "ngrams_type"
  93     }
  94   )
  95
  96 queryNodeNgramTable :: Query NodeNgramRead
  97 queryNodeNgramTable = queryTable nodeNgramTable
  98
  99 insertNodeNgrams :: [NodeNgram] -> Cmd err Int
 100 insertNodeNgrams = insertNodeNgramW
 101                  . map (\(NodeNgram _ n g w t) ->
 102                           NodeNgram Nothing (pgInt4 n)   (pgInt4 g)
 103                                             (pgDouble w) (pgInt4 t)
 104                         )
 105
 106 insertNodeNgramW :: [NodeNgramWrite] -> Cmd err Int
 107 insertNodeNgramW nns =
 108   mkCmd $ \c -> fromIntegral <$> runInsert_ c insertNothing
 109     where
 110       insertNothing = (Insert { iTable = nodeNgramTable
 111                               , iRows  = nns
 112                               , iReturning = rCount
 113                               , iOnConflict = (Just DoNothing)
 114                               })
 115
 116 type NgramsText = Text
 117
 118 updateNodeNgrams' :: [(ListId, NgramsText, ListTypeId)] -> Cmd err [Int]
 119 updateNodeNgrams' [] = pure []
 120 updateNodeNgrams' input = map (\(PGS.Only a) -> a) <$>
 121                           runPGSQuery 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 [Int]
 141 updateNodeNgrams nnu = do
 142   xs <- updateNodeNgrams' $ _nnu_lists_update nnu
 143   ys <- ngramsGroup Del   $ _nnu_rem_children nnu
 144   zs <- ngramsGroup Add   $ _nnu_add_children nnu
 145   pure $ xs <> ys <> zs