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