src/Gargantext/Database/Query/Table/NodeNgrams.hs

   1 {-|
   2 Module      : Gargantext.Database.Query.Table.NodeNgrams
   3 Description :
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 NodeNgrams register Context of Ngrams (named Cgrams then)
  11
  12 -}
  13
  14 {-# OPTIONS_GHC -fno-warn-orphans #-}
  15
  16 {-# LANGUAGE Arrows                 #-}
  17 {-# LANGUAGE FunctionalDependencies #-}
  18 {-# LANGUAGE QuasiQuotes            #-}
  19 {-# LANGUAGE TemplateHaskell        #-}
  20
  21 module Gargantext.Database.Query.Table.NodeNgrams
  22   ( getCgramsId
  23   , listInsertDb
  24   , module Gargantext.Database.Schema.NodeNgrams
  25   , queryNodeNgramsTable
  26   )
  27   where
  28
  29 import Data.List.Extra (nubOrd)
  30 import Data.Map.Strict (Map)
  31 import Data.Maybe (fromMaybe)
  32 import Data.Text (Text)
  33 import Gargantext.Core
  34 import Gargantext.Core.Types
  35 import Gargantext.Database.Prelude
  36 import Gargantext.Database.Schema.Ngrams (NgramsType, ngramsTypeId, fromNgramsTypeId)
  37 import Gargantext.Database.Schema.NodeNgrams
  38 import Gargantext.Database.Schema.Prelude (Select, FromRow, sql, fromRow, toField, field, Values(..), QualifiedIdentifier(..), selectTable)
  39 import Gargantext.Prelude
  40 import qualified Data.List as List
  41 import qualified Data.Map.Strict as Map
  42 import qualified Database.PostgreSQL.Simple as PGS (Query, Only(..))
  43
  44
  45 queryNodeNgramsTable :: Select NodeNgramsRead
  46 queryNodeNgramsTable = selectTable nodeNgramsTable
  47
  48
  49 -- | Type for query return
  50 data Returning = Returning { re_type      :: !(Maybe NgramsType)
  51                            , re_terms     :: !Text
  52                            , re_ngrams_id :: !Int
  53                            }
  54   deriving (Show)
  55
  56 instance FromRow Returning where
  57   fromRow = Returning <$> (fromNgramsTypeId <$> field) <*> field <*> field
  58
  59 getCgramsId :: Map NgramsType (Map Text Int) -> NgramsType -> Text -> Maybe Int
  60 getCgramsId mapId nt t = case Map.lookup nt mapId of
  61   Nothing     -> Nothing
  62   Just mapId' -> Map.lookup t mapId'
  63
  64
  65 -- insertDb :: ListId -> Map NgramsType [NgramsElement] -> Cmd err [Result]
  66 listInsertDb :: Show a => ListId
  67              -> (ListId -> a -> [NodeNgramsW])
  68              -> a
  69              -- -> Cmd err [Returning]
  70              -> Cmd err (Map NgramsType (Map Text Int))
  71 listInsertDb l f ngs = Map.map Map.fromList
  72                     <$> Map.fromListWith (<>)
  73                     <$> List.map (\(Returning t tx id) -> (fromJust t, [(tx, id)]))
  74                     <$> List.filter (\(Returning t _ _) -> isJust t)
  75                     <$> insertNodeNgrams (f l ngs)
  76
  77 -- TODO optimize with size of ngrams
  78 insertNodeNgrams :: [NodeNgramsW] -> Cmd err [Returning]
  79 insertNodeNgrams nns = runPGSQuery query (PGS.Only $ Values fields nns')
  80   where
  81     fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","text","int4"
  82                                                       ,"int4","int4","int4","int4"
  83                                                       ,"float8"]
  84     -- nns' :: [(Int, ListTypeId, NgramsText, NgramsTypeId ,NgramsField, NgramsTag, NgramsClass, Double)]
  85     nns' = map (\(NodeNgrams _id (NodeId node_id'') node_subtype ngrams_terms ngrams_type ngrams_field ngrams_tag ngrams_class weight)
  86                               -> [ toField node_id''
  87                                  , toField $ toDBid node_subtype
  88                                  , toField $ ngrams_terms
  89                                  , toField $ ngramsTypeId ngrams_type
  90                                  , toField $ fromMaybe 0 ngrams_field
  91                                  , toField $ fromMaybe 0 ngrams_tag
  92                                  , toField $ fromMaybe 0 ngrams_class
  93                                  , toField weight
  94                                  ]
  95                   ) $ nubOrd nns
  96
  97     query :: PGS.Query
  98     query = [sql|
  99           WITH input(node_id, node_subtype, ngrams_terms, ngrams_type, ngrams_field, ngrams_tag, ngrams_class, weight) AS (?),
 100           return(id, ngrams_type, ngrams_id) AS (
 101             INSERT INTO node_ngrams (node_id, node_subtype, ngrams_id, ngrams_type, ngrams_field, ngrams_tag, ngrams_class, weight)
 102             SELECT i.node_id, i.node_subtype, ng.id, i.ngrams_type, i.ngrams_field, i.ngrams_tag, i.ngrams_class, i.weight FROM input as i
 103             INNER JOIN ngrams as ng ON ng.terms = i.ngrams_terms
 104             ON CONFLICT(node_id, node_subtype, ngrams_id) DO NOTHING
 105             -- DO UPDATE SET node_subtype = excluded.node_subtype, ngrams_type = excluded.ngrams_type, ngrams_field = excluded.ngrams_field, ngrams_tag = excluded.ngrams_tag, ngrams_class = excluded.ngrams_class, weight = excluded.weight
 106             RETURNING id, ngrams_type, ngrams_id
 107           )
 108           SELECT return.ngrams_type, ng.terms, return.id FROM return
 109           INNER JOIN ngrams ng ON return.ngrams_id = ng.id;
 110   |]