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   )
  26   where
  27
  28 import Data.List.Extra (nubOrd)
  29 import Data.Map (Map)
  30 import Data.Maybe (fromMaybe)
  31 import Data.Text (Text)
  32 import Database.PostgreSQL.Simple (FromRow)
  33 import Database.PostgreSQL.Simple.FromRow (fromRow, field)
  34 import Database.PostgreSQL.Simple.SqlQQ (sql)
  35 import Database.PostgreSQL.Simple.ToField (toField)
  36 import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
  37 import Gargantext.Core
  38 import Gargantext.Core.Types
  39 import Gargantext.Database.Prelude
  40 import Gargantext.Database.Schema.Ngrams (NgramsType, ngramsTypeId, fromNgramsTypeId)
  41 import Gargantext.Database.Schema.NodeNgrams
  42 import Gargantext.Prelude
  43 import qualified Data.List as List
  44 import qualified Data.Map as Map
  45 import qualified Database.PostgreSQL.Simple as PGS (Query, Only(..))
  46
  47
  48 -- | Type for query return
  49 data Returning = Returning { re_type      :: !(Maybe NgramsType)
  50                            , re_terms     :: !Text
  51                            , re_ngrams_id :: !Int
  52                            }
  53   deriving (Show)
  54
  55 instance FromRow Returning where
  56   fromRow = Returning <$> (fromNgramsTypeId <$> field) <*> field <*> field
  57
  58 getCgramsId :: Map NgramsType (Map Text Int) -> NgramsType -> Text -> Maybe Int
  59 getCgramsId mapId nt t = case Map.lookup nt mapId of
  60   Nothing     -> Nothing
  61   Just mapId' -> Map.lookup t mapId'
  62
  63
  64 -- insertDb :: ListId -> Map NgramsType [NgramsElement] -> Cmd err [Result]
  65 listInsertDb :: Show a => ListId
  66              -> (ListId -> a -> [NodeNgramsW])
  67              -> a
  68              -- -> Cmd err [Returning]
  69              -> Cmd err (Map NgramsType (Map Text Int))
  70 listInsertDb l f ngs = Map.map Map.fromList
  71                     <$> Map.fromListWith (<>)
  72                     <$> List.map (\(Returning t tx id) -> (fromJust t, [(tx, id)]))
  73                     <$> List.filter (\(Returning t _ _) -> isJust t)
  74                     <$> insertNodeNgrams (f l ngs)
  75
  76 -- TODO optimize with size of ngrams
  77 insertNodeNgrams :: [NodeNgramsW] -> Cmd err [Returning]
  78 insertNodeNgrams nns = runPGSQuery query (PGS.Only $ Values fields nns')
  79   where
  80     fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","text","int4"
  81                                                       ,"int4","int4","int4","int4"
  82                                                       ,"float8"]
  83     -- nns' :: [(Int, ListTypeId, NgramsText, NgramsTypeId ,NgramsField, NgramsTag, NgramsClass, Double)]
  84     nns' = map (\(NodeNgrams _id (NodeId node_id'') node_subtype ngrams_terms ngrams_type ngrams_field ngrams_tag ngrams_class weight)
  85                               -> [ toField node_id''
  86                                  , toField $ toDBid node_subtype
  87                                  , toField $ ngrams_terms
  88                                  , toField $ ngramsTypeId ngrams_type
  89                                  , toField $ fromMaybe 0 ngrams_field
  90                                  , toField $ fromMaybe 0 ngrams_tag
  91                                  , toField $ fromMaybe 0 ngrams_class
  92                                  , toField weight
  93                                  ]
  94                   ) $ nubOrd nns
  95
  96     query :: PGS.Query
  97     query = [sql|
  98           WITH input(node_id, node_subtype, ngrams_terms, ngrams_type, ngrams_field, ngrams_tag, ngrams_class, weight) AS (?),
  99           return(id, ngrams_type, ngrams_id) AS (
 100             INSERT INTO node_ngrams (node_id, node_subtype, ngrams_id, ngrams_type, ngrams_field, ngrams_tag, ngrams_class, weight)
 101             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
 102             INNER JOIN ngrams as ng ON ng.terms = i.ngrams_terms
 103             ON CONFLICT(node_id, node_subtype, ngrams_id) DO NOTHING
 104             -- 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
 105             RETURNING id, ngrams_type, ngrams_id
 106           )
 107           SELECT return.ngrams_type, ng.terms, return.id FROM return
 108           INNER JOIN ngrams ng ON return.ngrams_id = ng.id;
 109   |]